home *** CD-ROM | disk | FTP | other *** search
/ InterCD 2001 May / may_2001.iso / intercd / root / Html / ^stIHEditor / setup.exe / {app} / tinyweb / SRC.ZIP / XBASE.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  2000-01-14  |  73.4 KB  |  3,001 lines
  1. //////////////////////////////////////////////////////////////////////////
  2. //
  3. //  TinyWeb Copyright (C) 1997-2000 RIT Research Labs
  4. //
  5. //  This programs is free for commercial and non-commercial use as long as
  6. //  the following conditions are aheared to.
  7. //
  8. //  Copyright remains RIT Research Labs, and as such any Copyright notices
  9. //  in the code are not to be removed. If this package is used in a
  10. //  product, RIT Research Labs should be given attribution as the RIT Research
  11. //  Labs of the parts of the library used. This can be in the form of a textual
  12. //  message at program startup or in documentation (online or textual)
  13. //  provided with the package.
  14. //
  15. //  Redistribution and use in source and binary forms, with or without
  16. //  modification, are permitted provided that the following conditions are
  17. //  met:
  18. //
  19. //  1. Redistributions of source code must retain the copyright
  20. //     notice, this list of conditions and the following disclaimer.
  21. //  2. Redistributions in binary form must reproduce the above copyright
  22. //     notice, this list of conditions and the following disclaimer in the
  23. //     documentation and/or other materials provided with the distribution.
  24. //  3. All advertising materials mentioning features or use of this software
  25. //     must display the following acknowledgement:
  26. //     "Based on TinyWeb Server by RIT Research Labs."
  27. //
  28. //  THIS SOFTWARE IS PROVIDED BY RIT RESEARCH LABS "AS IS" AND ANY EXPRESS
  29. //  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  30. //  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  31. //  DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR
  32. //  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  33. //  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  34. //  GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  35. //  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
  36. //  IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  37. //  OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  38. //  ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  39. //
  40. //  The licence and distribution terms for any publically available
  41. //  version or derivative of this code cannot be changed. i.e. this code
  42. //  cannot simply be copied and put under another distribution licence
  43. //  (including the GNU Public Licence).
  44. //
  45. //////////////////////////////////////////////////////////////////////////
  46.  
  47.  
  48.  
  49. unit xBase;
  50.  
  51. interface uses Windows, WinSock;
  52.  
  53. const
  54.  
  55.  
  56.   _INADDR_ANY = INADDR_ANY;
  57.   INVALID_FILE_ATTRIBUTES = INVALID_FILE_SIZE;
  58.   INVALID_FILE_TIME       = INVALID_FILE_SIZE;
  59.   INVALID_REGISTRY_KEY    = INVALID_HANDLE_VALUE;
  60.   INVALID_VALUE           = INVALID_HANDLE_VALUE;
  61.  
  62.   rrLoHexChar: array[0..$F] of char='0123456789abcdef';
  63.   rrHiHexChar: array[0..$F] of char='0123456789ABCDEF';
  64.  
  65.   SleepQuant = 1*60*1000; // 1 minute
  66.  
  67. { Maximum TColl size }
  68.  
  69.   MaxCollSize = $20000 div SizeOf(Pointer);
  70.  
  71. const
  72.       MMaxChars = 250;
  73.  
  74.  
  75. type
  76.     Str255 = String[255];
  77.     TByteTable = Array[Char] of Byte;
  78.     TBase64Table = (bsBase64, bsUUE, bsXXE);
  79.     TUUStr = String[MMaxChars];
  80.  
  81.  
  82.     TMimeCoder = class
  83.       Table: string;
  84.       MaxChars: Byte;
  85.       Pad: Char;
  86.       XChars: TByteTable;
  87.       constructor Create(AType: TBase64Table);
  88.       procedure   InitTable;
  89.       function    Encode(const Buf; N: byte) : string;
  90.       function    EncodeBuf(const Buf; N: byte; var OutBuf) : Integer;
  91.       function    EncodeStr(const S: String): String;
  92.       function    Decode(const S : String; var Buf): Integer;
  93.       function    DecodeBuf(const SrcBuf; SrcLen: Integer; var Buf): Integer;
  94.     end;
  95.  
  96.  
  97.     TSocketOption = (soBroadcast, soDebug, soDontLinger,
  98.                      soDontRoute, soKeepAlive, soOOBInLine,
  99.                      soReuseAddr, soNoDelay, soBlocking, soAcceptConn);
  100.  
  101.     TSocketOptions = Set of TSocketOption;
  102.  
  103.     TSocketClass = class of TSocket;
  104.  
  105.     TSocket = class
  106.     public
  107.       Dead: Integer;
  108.       FPort: DWORD;
  109.       FAddr: DWORD;
  110.       Handle: DWORD;
  111.       Status: Integer;
  112.       Registered: Boolean;
  113.       procedure RegisterSelf;
  114.       procedure DeregisterSelf;
  115.  
  116.       function Startup: Boolean; virtual;
  117.       function Handshake: Boolean; virtual;
  118.       destructor Destroy; override;
  119.  
  120.       function Read(var B; Size: DWORD): DWORD;
  121.       function Write(const B; Size: DWORD): DWORD;
  122.       function WriteStr(const s: string): DWORD;
  123.  
  124.       function _Write(const B; Size: DWORD): DWORD; virtual;
  125.       function _Read(var B; Size: DWORD): DWORD; virtual;
  126.  
  127.     end;
  128.  
  129.   TObjProc = procedure of object;
  130.   TForEachProc = procedure(P: Pointer) of object;
  131.  
  132.   PFileInfo = ^TFileInfo;
  133.   TFileInfo = record
  134.     Attr: DWORD;
  135.     Size: DWORD;
  136.     Time: DWORD;
  137.   end;
  138.  
  139.   TuFindData = record
  140.     Info: TFileInfo;
  141.     FName: string;
  142.   end;
  143.  
  144.   TCreateFileMode = (
  145.  
  146.    cRead,            // Specifies read access to the file
  147.    cWrite,           // Specifies write access to the file
  148.  
  149.    cFlag,
  150.  
  151.    cEnsureNew,       // Creates a NEW file. The function fails
  152.                      // if the specified file already exists.
  153.  
  154.    cTruncate,        // Once opened, the file is truncated so that
  155.                      // its size is zero bytes.
  156.  
  157.    cExisting,        //  For communications resources, console diveces
  158.  
  159.    cShareAllowWrite,
  160.    cShareDenyRead,
  161.  
  162.    cOverlapped,      // This flag enables more than one operation to be
  163.                      // performed simultaneously with the handle
  164.                      // (e.g. a simultaneous read and write operation).
  165.  
  166.    cRandomAccess,    // Indicates that the file is accessed randomly.
  167.                      // Windows uses this flag to optimize file caching.
  168.  
  169.    cSequentialScan,  // Indicates that the file is to be accessed
  170.                      // sequentially from beginning to end.
  171.  
  172.    cDeleteOnClose    // Indicates that the operating system is to delete
  173.                      // the file immediately after all of its handles
  174.                      // have been closed.
  175.  
  176.                     );
  177.  
  178.    TCreateFileModeSet = set of TCreateFileMode;
  179.  
  180. { Character set type }
  181.  
  182.   PCharSet = ^TCharSet;
  183.   TCharSet = set of Char;
  184.  
  185. { General arrays }
  186.  
  187.  
  188.   PCharArray = ^TCharArray;
  189.   TCharArray = array[0..MaxLongInt-1] of Char;
  190.  
  191.   PByteArray = ^TByteArray;
  192.   TByteArray = array[0..MaxLongInt-1] of Byte;
  193.  
  194.   PIntArray = ^TIntArray;
  195.   TIntArray = array[0..(MaxLongInt div 4)-1] of Integer;
  196.  
  197.   PDwordArray = ^TDwordArray;
  198.   TDwordArray = array[0..(MaxLongInt div 4)-1] of DWORD;
  199.  
  200.  
  201.   PvIntArr = ^TvIntArr;
  202.   TvIntArr = record
  203.     Arr: PIntArray;
  204.     Cnt: Integer;
  205.   end;
  206.  
  207.   PBoolean   = ^Boolean;
  208.  
  209.  
  210.   PItemList = ^TItemList;
  211.   TItemList = array[0..MaxCollSize - 1] of Pointer;
  212.  
  213.   TThreadMethod = procedure of object;
  214.   TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
  215.     tpTimeCritical);
  216.  
  217.   TThread = class
  218.   private
  219.     FHandle: THandle;
  220.     FThreadID: THandle;
  221.     FTerminated: Boolean;
  222.     FSuspended: Boolean;
  223.     FFreeOnTerminate: Boolean;
  224.     FFinished: Boolean;
  225.     FReturnValue: DWORD;
  226.     function GetPriority: TThreadPriority;
  227.     procedure SetPriority(Value: TThreadPriority);
  228.     procedure SetSuspended(Value: Boolean);
  229.   protected
  230.     procedure Execute; virtual; abstract;
  231.     property ReturnValue: DWORD read FReturnValue write FReturnValue;
  232.     property Terminated: Boolean read FTerminated;
  233.   public
  234.     constructor Create(CreateSuspended: Boolean);
  235.     destructor Destroy; override;
  236.     procedure Resume;
  237.     procedure Suspend;
  238.     procedure Terminate;
  239.     property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
  240.     property Handle: THandle read FHandle;
  241.     property Priority: TThreadPriority read GetPriority write SetPriority;
  242.     property Suspended: Boolean read FSuspended write SetSuspended;
  243.     property ThreadID: THandle read FThreadID;
  244.   end;
  245.  
  246.   TAdvObject = class;
  247.  
  248.   TAdvObject = class
  249.   end;
  250.  
  251.   TAdvCpObject = class(TAdvObject)
  252.     function Copy: Pointer; virtual; abstract;
  253.   end;
  254.  
  255.   TAdvClass = class of TAdvObject;
  256.  
  257.   TCollClass = class of TColl;
  258.  
  259.   TListSortCompare = function (Item1, Item2: Pointer): Integer;
  260.  
  261.   TColl = class(TAdvCpObject)
  262.   protected
  263.     FCount: Integer;
  264.     FCapacity: Integer;
  265.     FDelta: Integer;
  266.     CS: TRTLCriticalSection;
  267.     Shared: Integer;
  268.   public
  269.     FList: PItemList;
  270.     procedure CopyItemsTo(Coll: TColl);
  271.     function Copy: Pointer; override;
  272.     function CopyItem(AItem: Pointer): Pointer; virtual;
  273.     procedure DoInit(ALimit, ADelta: Integer);
  274.     constructor Create;
  275.     destructor Destroy; override;
  276.     function At(Index: Integer): Pointer;
  277.     procedure AtDelete(Index: Integer);
  278.     procedure AtFree(Index: Integer);
  279.     procedure AtInsert(Index: Integer; Item: Pointer);
  280.     procedure AtPut(Index: Integer; Item: Pointer);
  281.     procedure Delete(Item: Pointer);
  282.     procedure DeleteAll;
  283.     procedure FFree(Item: Pointer);
  284.     procedure FreeAll;
  285.     procedure FreeItem(Item: Pointer); virtual;
  286.     function IndexOf(Item: Pointer): Integer; virtual;
  287.     procedure Insert(Item: Pointer); virtual;
  288.     procedure Add(Item: Pointer);
  289.     procedure Pack;
  290.     procedure SetCapacity(NewCapacity: Integer);
  291.     procedure MoveTo(CurIndex, NewIndex: Integer);
  292.     property Items[Idx: Integer]: Pointer read At write AtPut; default;
  293.     property Count: Integer read FCount;
  294.     property First: Pointer index 0 read At write AtPut;
  295.     procedure ForEach(Proc: TForEachProc); virtual;
  296.     procedure Sort(Compare: TListSortCompare);
  297.     procedure Concat(AColl: TColl);
  298.     procedure Enter;
  299.     procedure Leave;
  300.   end;
  301.  
  302.   TSortedColl = class(TColl)
  303.   public
  304.     Duplicates: Boolean;
  305.     function Compare(Key1, Key2: Pointer): Integer; virtual; abstract;
  306.     function KeyOf(Item: Pointer): Pointer; virtual;
  307.     function IndexOf(Item: Pointer): Integer; override;
  308.     procedure Insert(Item: Pointer); override;
  309.     function Search(Key: Pointer; var Index: Integer): Boolean; virtual;
  310.   end;
  311.  
  312. { TStringColl object }
  313.  
  314.   TStringColl = class(TSortedColl)
  315.   protected
  316.     procedure SetString(Index: Integer; const Value: string);
  317.     function GetString(Index: Integer): string;
  318.   public
  319.     function KeyOf(Item: Pointer): Pointer; override;
  320.     procedure FreeItem(Item: Pointer); override;
  321.     function Compare(Key1, Key2: Pointer): Integer; override;
  322.     function CopyItem(AItem: Pointer): Pointer; override;
  323.     function Copy: Pointer; override;
  324.     procedure Ins(const S: string);
  325.     procedure Ins0(const S: string);
  326.     procedure Add(const S: string);
  327.     procedure AtIns(Index: Integer; const Item: string);
  328.     property Strings[Index: Integer]: string read GetString write SetString; default;
  329.     function  IdxOf(Item: string): Integer;
  330.     procedure AppendTo(AColl: TStringColl);
  331.     procedure Concat(AColl: TStringColl);
  332.     procedure AddStrings(Strings: TStringColl; Sort: Boolean);
  333.     procedure Fill(const AStrs: array of string);
  334.     function Found(const Str: string): Boolean;
  335.     function FoundU(const Str: string): Boolean;
  336.     function FoundUC(const Str: string): Boolean;
  337.     procedure FillEnum(Str: string; Delim: Char; Sorted: Boolean);
  338.     function LongString: string;
  339.     function LongStringD(c: char): string;
  340.     procedure SetTextStr(const Value: string);
  341.   end;
  342.  
  343.  
  344. { --- string routines }
  345.  
  346. function  AddRightSpaces(const S: string; NumSpaces: Integer): string;
  347. procedure AddStr(var S: string ; C : char);
  348. procedure Add_Str(var S: ShortString ; C : char);
  349. function  CompareStr(const S1, S2: string): Integer; assembler;
  350. function  CopyLeft(const S: string; I: Integer): string;
  351. procedure DelDoubles(const St : string;var Source : string);
  352. procedure DelFC(var s: string);
  353. procedure DelLC(var s: string);
  354. function  DelLeft(const S: string): string;
  355. function  DelRight(const S: string): string;
  356. function  DelSpaces(const s: string): string;
  357. procedure DeleteLeft(var S: string; I: Integer);
  358. function  DigitsOnly(const AStr: string): Boolean;
  359. procedure DisposeStr(P: PString);
  360. function  ExpandFileName(const FileName: string): string;
  361. function  ExtractFilePath(const FileName: string): string;
  362. function  ExtractDir(const S: string): string;
  363. function  ExtractFileRoot(const FileName: string): string;
  364. function  ExtractFileExt(const FileName: string): string;
  365. function  ExtractFileName(const FileName: string): string;
  366. function  ExtractFileDrive(const FileName: string): string;
  367. function  ExtractFileDir(const FileName: string): string;
  368. procedure FSplit(const FName: string; var Path, Name, Ext: string);
  369. procedure FillCharSet(const AStr: string; var CharSet: TCharSet);
  370. procedure GetWrdStrictUC(var s,w:string);
  371. procedure GetWrdStrict(var s,w:string);
  372. procedure GetWrdD(var s,w:string);
  373. procedure GetWrdA(var s,w:string);
  374. procedure GetWrd(var s,w:string;c:char);
  375. function  Hex2(a: Byte): string;
  376. function  Hex4(a: Word): string;
  377. function  Hex8(a: DWORD): string;
  378. function  Int2Hex(a: Integer): string;
  379. function  Int2Str(L: Integer): string;
  380. function  ItoS(I: Integer): string;
  381. function  ItoSz(I, Width: Integer): string;
  382. function  LastDelimiter(const Delimiters, S: string): Integer;
  383. function  LowerCase(const S: string): string;
  384. function  MakeFullDir(const D, S: string): string;
  385. function  MakeNormName(const Path, Name: string): string;
  386. function  MonthE(m: Integer): string;
  387. function  NewStr(const S: string): PString;
  388. function  Replace(const Pattern, ReplaceString: string; var S: string): Boolean;
  389. function  StoI(const S: string): Integer;
  390. function  StrEnds(const S1, S2: string): Boolean;
  391. function  StrRight(const S: string; Num: Integer): string;
  392. function  UpperCase(const S: string): string;
  393. function  WipeChars(const AStr, AWipeChars: string): string;
  394. function  _Val(const S: string; var V: Integer): Boolean;
  395.  
  396. { --- RFC Routines }
  397.  
  398. function  ProcessQuotes(var s: string): Boolean;
  399. function  UnpackPchars(var s: string): Boolean;
  400. function  UnpackUchars(var s: string): Boolean;
  401. function  __alpha(c: char): Boolean;
  402. function  __ctl(c: char): Boolean;
  403. function  __digit(c: char): Boolean;
  404. function  __extra(c: char): Boolean;
  405. function  __national(c: char): Boolean;
  406. function  __pchar(c: char): Boolean;
  407. function  __reserved(c: char): Boolean;
  408. function  __safe(c: char): Boolean;
  409. function  __uchar(c: char): Boolean;
  410. function  __unsafe(c: char): Boolean;
  411.  
  412. { --- Basic Routines }
  413.  
  414. function  Buf2Str(const Buffer): string;
  415. procedure Clear(var Buf; Count: Integer);
  416. function  CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
  417. procedure FreeObject(var O);
  418. procedure LowerPrec(var A, B: Integer; Bits: Byte);
  419. function  MemEqu(const A, B; Sz: Integer): Boolean;
  420. function  MaxI(A, B: Integer): Integer;
  421. function  MinI(A, B: Integer): Integer;
  422. function  MaxD(A, B: DWORD): DWORD;
  423. function  MinD(A, B: DWORD): DWORD;
  424. function  NulSearch(const Buffer): Integer;
  425. function  NumBits(I: Integer): Integer;
  426. procedure XAdd(var Critical, Normal); assembler;
  427. procedure XChg(var Critical, Normal); assembler;
  428.  
  429. { --- Win32 Events Extentions }
  430.  
  431. function  CreateEvtA: DWORD;
  432. function  CreateEvt(Initial: Boolean): DWORD;
  433. function  SignaledEvt(id: DWORD): Boolean;
  434. function  WaitEvt(const id: TWOHandleArray; Timeout: DWORD): DWORD;
  435. function  WaitEvtA(nCount: Integer; lpHandles: PWOHandleArray; Timeout: DWORD): DWORD;
  436.  
  437. { --- Win32 API Hooks }
  438.  
  439. function  ClearHandle(var Handle: THandle): Boolean;
  440. procedure CloseHandles(const Handles: array of DWORD);
  441. function  FileExists(const FName: string): Boolean;
  442. function  FindExecutable(FileName, Directory: PChar; Result: PChar): HINST; stdcall;
  443. function  GetEnvVariable(const Name: string): string;
  444. function  GetFileNfo(const FName: string; var Info: TFileInfo; NeedAttr: Boolean): Boolean;
  445. function  GetFileNfoByHandle(Handle: DWORD; var Info: TFileInfo): Boolean;
  446. function  ZeroHandle(var Handle: THandle): Boolean;
  447.  
  448. function  _CreateFile(const FName: string; Mode: TCreateFileModeSet): DWORD;
  449. function  _CreateFileSecurity(const FName: string; Mode: TCreateFileModeSet; lpSecurityAttributes: PSecurityAttributes): DWORD;
  450. function  _GetFileSize(const FName: string): DWORD;
  451.  
  452. function _MatchMaskBody(AName, AMask: string; SupportPercent: Boolean): Boolean;
  453. function _MatchMask(const AName: string; AMask: string; SupportPercent: Boolean): Boolean;
  454. function MatchMask(const AName, AMask: string): Boolean;
  455.  
  456. function  SysErrorMsg(ErrorCode: DWORD): string;
  457.  
  458. { --- Registry Routines }
  459.  
  460. function  CreateRegKey(const AFName: string): HKey;
  461. function  OpenRegKeyEx(const AName: string; AMode: DWORD): HKey;
  462. function  OpenRegKey(const AName: string): DWORD;
  463. function  ReadRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  464. function  ReadRegInt(Key: DWORD; const AStrName: string): DWORD;
  465. function  ReadRegString(Key: DWORD; const AStrName: string): string;
  466. function  WriteRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  467. function  WriteRegInt(Key: DWORD; const AStrName: string; AValue: DWORD): Boolean;
  468. function  WriteRegString(Key: DWORD; const AStrName, AStr: string): Boolean;
  469.  
  470. { --- Winsock tools }
  471.  
  472. function  AddrInet(i: DWORD): string;
  473. function  GetHostNameByAddr(Addr: DWORD): string;
  474. function  Inet2addr(const s: string): DWORD;
  475. function  InetAddr(const s: string): DWORD;
  476.  
  477. { --- Misc tools }
  478.  
  479. procedure GlobalFail;
  480. function  _LogOK(const Name: string; var Handle: DWORD): Boolean;
  481. procedure xBaseDone;
  482. procedure xBaseInit;
  483. procedure uCvtSetFileTime(T: DWORD; var L, H: DWORD);
  484. function uCvtGetFileTime(L, H: DWORD): DWORD;
  485. function uGetSystemTime: DWORD;
  486. function Vl(const s: string): DWORD;
  487. function StrAsg(const Src: string): string;
  488.  
  489. type
  490.   TResetterThread = class(TThread)
  491.     TimeToSleep,
  492.     oSleep: DWORD;
  493.     constructor Create;
  494.     procedure Execute; override;
  495.     destructor Destroy; override;
  496.   end;
  497.  
  498.  
  499. var
  500.   ResetterThread: TResetterThread;
  501.   TimeZoneBias: Integer;
  502.   SocketsColl: TColl;
  503.   SocksCount: Integer;
  504.  
  505. const
  506.   CServerVersion = '1.8';
  507.   CServerProductName = 'TinyWeb';
  508.   CServerName = CServerProductName+'/'+CServerVersion;
  509.   CMB_FAILED = MB_APPLMODAL or MB_OK or MB_ICONSTOP;
  510.  
  511.  
  512. implementation
  513.  
  514.  
  515. ////////////////////////////////////////////////////////////////////////
  516. //                                                                    //
  517. //                          Time Routines                             //
  518. //                                                                    //
  519. ////////////////////////////////////////////////////////////////////////
  520.  
  521.  
  522.  
  523. const
  524.   cTimeHi   = 27111902;
  525.   cTimeLo   = -717324288;
  526.   cSecScale = 10000000;
  527.   cAgeScale = 10000;
  528.  
  529. function uCvtGetFileTime(L, H: DWORD): DWORD; assembler;
  530. asm
  531.   mov ecx, cSecScale
  532.   sub eax, cTimeLo
  533.   sbb edx, cTimeHi
  534.   jns @@ns
  535.   mov eax, 0
  536.   jmp @@ok
  537. @@ns:
  538.   div ecx
  539.   test eax, eax
  540.   jns @@ok
  541.   mov eax, MaxInt
  542. @@ok:
  543. end;
  544.  
  545. function uCvtGetFileAge(L, H: DWORD): DWORD; assembler;
  546. asm
  547.   mov ecx, cAgeScale
  548.   div ecx
  549. end;
  550.  
  551.  
  552. procedure uCvtSetFileTime(T: DWORD; var L, H: DWORD); assembler;
  553. asm
  554.   push edx
  555.   push ebx
  556.   mov  ebx, cSecScale
  557.   mul  ebx
  558.   pop  ebx
  559.   add  eax, cTimeLo
  560.   adc  edx, cTimeHi
  561.   mov  [ecx], edx
  562.   pop  edx
  563.   mov  [edx], eax
  564. end;
  565.  
  566.  
  567. procedure uNix2WinTime(I: DWORD; var T: TSystemTime);
  568. var
  569.   F: TFileTime;
  570. begin
  571.   uCvtSetFileTime(I, F.dwLowDateTime, F.dwHighDateTime);
  572.   FileTimeToSystemTime(F, T);
  573. end;
  574.  
  575. function uWin2NixTime(const T: TSystemTime): DWORD;
  576. var
  577.   F: TFileTime;
  578. begin
  579.   SystemTimeToFileTime(T, F);
  580.   Result := uCvtGetFileTime(F.dwLowDateTime, F.dwHighDateTime);
  581. end;
  582.  
  583.  
  584.  
  585. function uGetLocalTime: DWORD;
  586. begin
  587.   Result := uGetLocalTime;
  588. end;
  589.  
  590. function uGetSystemTime: DWORD;
  591. var
  592.   T: TFileTime;
  593. begin
  594.   GetSystemTimeAsFileTime(T);
  595.   Result := uCvtGetFileTime(T.dwLowDateTime, T.dwHighDateTime);
  596. end;
  597.  
  598. function uSetFileTimeByHandle(Handle: DWORD; uTime: DWORD): Boolean;
  599. var
  600.   F: TFileTime;
  601. begin
  602.   uCvtSetFileTime(uTime, F.dwLowDateTime, F.dwHighDateTime);
  603.   Result := SetFileTime(Handle, nil, nil, @F);
  604. end;
  605.  
  606. function uSetFileTime(const FName: string; uTime: DWORD): Boolean;
  607. var
  608.   Handle: DWORD;
  609. begin
  610.   Result := False;
  611.   Handle := _CreateFile(FName, [cWrite, cExisting]);
  612.   if Handle = INVALID_HANDLE_VALUE then Exit;
  613.   Result := uSetFileTimeByHandle(Handle, uTime);
  614.   CloseHandle(Handle);
  615. end;
  616.  
  617. procedure CvtFD(const wf: TWin32FindData; var FindData: TuFindData);
  618. begin
  619.   FindData.Info.Attr := wf.dwFileAttributes;
  620.   FindData.Info.Time := uCvtGetFileTime(wf.ftLastWriteTime.dwLowDateTime, wf.ftLastWriteTime.dwHighDateTime);
  621.   FindData.Info.Size := wf.nFileSizeLow;
  622.   FindData.FName := Buf2Str(wf.cFileName);
  623. end;
  624.  
  625. function uFindFirst(const FName: string; var FindData: TuFindData): DWORD;
  626. var
  627.   wf: TWin32FindData;
  628. begin
  629.   Result := FindFirstFile(PChar(FName), wf);
  630.   if Result <> INVALID_HANDLE_VALUE then CvtFD(wf, FindData);
  631. end;
  632.  
  633. function uFindNext(Handle: DWORD; var FindData: TuFindData): Boolean;
  634. var
  635.   wf: TWin32FindData;
  636. begin
  637.   Result := FindNextFile(Handle, wf);
  638.   if Result then CvtFD(wf, FindData);
  639. end;
  640.  
  641. function uFindClose(Handle: DWORD): Boolean;
  642. begin
  643.   Result := Windows.FindClose(Handle);
  644. end;
  645.  
  646.  
  647.  
  648. ////////////////////////////////////////////////////////////////////////
  649. //                                                                    //
  650. //                         string Routines                            //
  651. //                                                                    //
  652. ////////////////////////////////////////////////////////////////////////
  653.  
  654.  
  655. function IsWild(const S: string): Boolean;
  656. begin
  657.   Result := (Pos('*',S)>0) or (Pos('?', S)>0);
  658. end;
  659.  
  660. function TrimZeros(S: string): string;
  661. var
  662.   I, J : Integer;
  663. begin
  664.   I := Length(S);
  665.   while (I > 0) and (S[I] <= ' ') do
  666.     Dec(I);
  667.   J := 1;
  668.   while (J < I) and ((S[J] <= ' ') or (S[J] = '0')) do
  669.     Inc(J);
  670.   TrimZeros := Copy(S, J, (I-J)+1);
  671. end;
  672.  
  673. function BothKVC(const S: string): Boolean;
  674. begin
  675.   Result := (Copy(S, 1, 1)='"') and (Copy(S, Length(S), 1)='"');
  676. end;
  677.  
  678. function AddRightSpaces;
  679. begin
  680.   SetLength(Result, NumSpaces);
  681.   FillChar(Result[1], NumSpaces, ' ');
  682.   Move(S[1], Result[1], MinI(NumSpaces, Length(S)));
  683. end;
  684.  
  685. function Hex2;
  686. begin
  687.   SetLength(Result, 2);
  688.   Result[1] := rrLoHexChar[a shr 4];
  689.   Result[2] := rrLoHexChar[a and $F];
  690. end;
  691.  
  692. function Hex4;
  693.   var I: Integer;
  694. begin
  695.   SetLength(Result, 4);
  696.   for I := 0 to 3 do
  697.     begin Result[4-I] := rrLoHexChar[A and $F]; A := A shr 4; end;
  698. end;
  699.  
  700. function Hex8;
  701.   var I: DWORD;
  702. begin
  703.   SetLength(Result, 8);
  704.   for I := 0 to 7 do
  705.     begin Result[8-I] := rrLoHexChar[A and $F]; A := A shr 4; end;
  706. end;
  707.  
  708. function Int2Hex(a: Integer): string;
  709. begin
  710.   Result := Hex8(a);
  711.   while (Length(Result)>1) and (Result[1]='0') do DelFC(Result);
  712. end;
  713.  
  714. function MakeFullDir(const D, S: string): string;
  715. begin
  716.   if (Pos(':', S) > 0) or (Copy(S, 1, 2) = '\\') then Result := S else
  717.     if Copy(S, 1, 1) = '\' then Result := MakeNormName(Copy(D, 1, Pos(':',D)), Copy(S, 2, Length(S)-1)) else
  718.       Result := MakeNormName(D,S);
  719. end;
  720.  
  721. function ExtractDir;
  722. var
  723.   i: Integer;
  724. begin
  725.   Result := S; i := Length(S);
  726.   if (i > 3) and (S[i] = '\') then DelLC(Result);
  727. end;
  728.  
  729. function MakeNormName;
  730. begin
  731.   Result := Path;
  732.   if (Result <> '') and (Result[Length(Result)] <> '\') then AddStr(Result, '\');
  733.   Result := Result + Name;
  734. end;
  735.  
  736. procedure AddStr;
  737. begin
  738.   S := S + C;
  739. end;
  740.  
  741. procedure Add_Str(var S: ShortString ; C : char);
  742. var
  743.   sl: Byte absolute S;
  744. begin
  745.   Inc(sl); S[sl] := C;
  746. end;
  747.  
  748. procedure FSplit(const FName: string; var Path, Name, Ext: string);
  749. type
  750.   TStep = (sExt, sName, sPath);
  751. var
  752.   Step : TStep;
  753.   I: Integer;
  754.   C: Char;
  755. begin
  756.   I := Length(FName);
  757.   if Pos('.', FName) = 0 then Step := sName else Step := sExt;
  758.   Path := ''; Name := ''; Ext  := '';
  759.   while I > 0 do
  760.   begin
  761.     C := FName[I]; Dec(I);
  762.     case Step of
  763.       sExt  :
  764.         case C of
  765.           '.': begin Ext := C + Ext; Inc(Step); end;
  766.           '\', ':': begin Name := Ext; Ext := ''; Path := C; Step := sPath; end;
  767.           else Ext := C + Ext;
  768.         end;
  769.       sName : if (C = '\') or (C = ':') then begin Path := C; Inc(Step) end else Name := C + Name;
  770.       sPath : Path := C + Path;
  771.     end;
  772.   end;
  773. end;
  774.  
  775.  
  776. function Replace;
  777.  var I, J: Integer;
  778.      LP, LR: Integer;
  779. begin
  780.  Result := False;
  781.  J := 1;
  782.  LP := Length(Pattern);
  783.  LR := Length(ReplaceString);
  784.  repeat
  785.   I := Pos(Pattern, CopyLeft(S, J));
  786.   if I > 0 then
  787.    begin
  788.     Delete(S, J+I-1, LP);
  789.     Insert(ReplaceString, S, J+I-1);
  790.     Result := True;
  791.    end;
  792.   Inc(J, I + LR - 1);
  793.  until I = 0;
  794. end;
  795.  
  796. procedure DelDoubles;
  797. var
  798.   i: Integer;
  799. begin
  800.   repeat
  801.     i := Pos(ST,Source);
  802.     if i = 0 then Break;
  803.     Delete(Source,I,1);
  804.   until False;
  805. end;
  806.  
  807. function ItoS(I: Integer): string;
  808. begin
  809.   Str(I, Result);
  810. end;
  811.  
  812. function ItoSz(I, Width: Integer): string;
  813. begin
  814.   Result := ItoS(I);
  815.   while Length(Result)<Width do Result := '0'+Result;
  816. end;
  817.  
  818. function DelLeft(const S: string): string;
  819. var
  820.   I, L: Integer;
  821. begin
  822.   I := 1;
  823.   L := Length(S);
  824.   while I<=L do
  825.   begin
  826.     case S[I] of #9, ' ':; else Break end;
  827.     Inc(I);
  828.   end;
  829.   Result := Copy(S, I, L+1-I);
  830. end;
  831.  
  832. function DelRight(const S: string): string;
  833. var
  834.   I: Integer;
  835. begin
  836.   I := Length(S);
  837.   while I>0 do
  838.   begin
  839.     case S[I] of #9, ' ':; else Break end;
  840.     Dec(I);
  841.   end;
  842.   Result := Copy(S, 1, I);
  843. end;
  844.  
  845. function DelSpaces(const s: string): string;
  846. begin
  847.   Result := DelLeft(DelRight(s));
  848. end;
  849.  
  850. procedure DelFC(var s: string);
  851. begin
  852.   Delete(s, 1, 1);
  853. end;
  854.  
  855. procedure DelLC(var s: string);
  856. var
  857.   l: Integer;
  858. begin
  859.   l := Length(s);
  860.   case l of
  861.     0 : ;
  862.     1 : s := '';
  863.     else SetLength(s, l-1);
  864.   end;
  865. end;
  866.  
  867. function Int2Str(L: Integer): string;
  868. var I: Integer;
  869. begin
  870.   Result := ItoS(L);
  871.   I := Length(Result)-2;
  872.   while I > 1 do
  873.     begin
  874.       Insert(','{ThousandSeparator}, Result, I);
  875.       Dec(I, 3);
  876.     end;
  877. end;
  878.  
  879. function ExtractFileRoot(const FileName: string): string;
  880. begin
  881.   Result := Copy(FileName, 1, Pos(':',FileName)+1);
  882. end;
  883.  
  884. function WipeChars;
  885. var
  886.   i, j: Integer;
  887. begin
  888.   Result := ''; j := Length(AStr);
  889.   for i := 1 to j do if Pos(AStr[I], AWipeChars) = 0 then AddStr(Result, AStr[I]);
  890. end;
  891.  
  892. procedure FillCharSet(const AStr: string; var CharSet: TCharSet);
  893. var
  894.   i: Integer;
  895. begin
  896.   CharSet := [];
  897.   for i := 1 to Length(AStr) do Include(CharSet, AStr[i]);
  898. end;
  899.  
  900. function DigitsOnly(const AStr: string): Boolean;
  901. var
  902.   i: Integer;
  903. begin
  904.   Result := False;
  905.   if AStr = '' then Exit;
  906.   for i := 1 to Length(AStr) do if not __digit(AStr[i]) then Exit;
  907.   Result := True;
  908. end;
  909.  
  910. procedure GetWrdD(var s,w:string);
  911. begin
  912.  w:=''; if s='' then Exit;
  913.  while (Length(s)>0) and ((s[1]<'0') or (s[1]>'9')) do begin DelFC(s) end;
  914.  while (Length(s)>0) and (s[1]>='0') and (s[1]<='9') do begin w:=w+s[1];DelFC(s) end;
  915.  DelFC(s);
  916. end;
  917.  
  918. procedure GetWrdA(var s,w:string);
  919. begin
  920.  w:=''; if s='' then Exit;
  921.  while (Length(s)>0) and ((UpCase(s[1])<'A') or (UpCase(s[1])>'Z')) do begin DelFC(s) end;
  922.  while (Length(s)>0) and (UpCase(s[1])>='A') and (UpCase(s[1])<='Z') do begin w:=w+s[1];DelFC(s) end;
  923.  DelFC(s);
  924. end;
  925.  
  926.  
  927. procedure GetWrd(var s,w:string;c:char);
  928. begin
  929.  w:=''; if s='' then Exit;
  930.  if c = ' ' then s := DelSpaces(s);
  931.  while (Length(s)>0) and (s[1]<>c) do begin w:=w+s[1];DelFC(s) end;
  932.  DelFC(s);
  933. end;
  934.  
  935. procedure GetWrdStrict(var s,w:string);
  936. begin
  937.   w:=''; if s='' then Exit;
  938.   while (Length(s)>0) and (s[1]<>' ') do begin w:=w+s[1];DelFC(s) end;
  939.   DelFC(s);
  940. end;
  941.  
  942. procedure GetWrdStrictUC(var s,w:string);
  943. begin
  944.   w:=''; if s='' then Exit;
  945.   while (Length(s)>0) and (s[1]<>' ') do begin w:=w+UpCase(s[1]);DelFC(s) end;
  946.   DelFC(s);
  947. end;
  948.  
  949. function StrRight(const S: string; Num: Integer): string;
  950. begin
  951.   Result := Copy(S, Length(S)-Num+1, Num);
  952. end;
  953.  
  954. function StrEnds(const S1, S2: string): Boolean;
  955. begin
  956.   Result := StrRight(S1, Length(S2)) = S2;
  957. end;
  958.  
  959. function CopyLeft(const S: string; I: Integer): string;
  960. begin
  961.   Result := Copy(S, I, Length(S)-I+1);
  962. end;
  963.  
  964. procedure DeleteLeft(var S: string; I: Integer);
  965. begin
  966.   Delete(S, I, Length(S)-I+1);
  967. end;
  968.  
  969.  
  970. ////////////////////////////////////////////////////////////////////////
  971. //                                                                    //
  972. //                          Basic Routines                            //
  973. //                                                                    //
  974. ////////////////////////////////////////////////////////////////////////
  975.  
  976. procedure Clear(var Buf; Count: Integer);
  977. begin
  978.   FillChar(Buf, Count, 0);
  979. end;
  980.  
  981. function MemEqu(const A, B; Sz: Integer): Boolean;
  982. asm
  983.     push  ebx
  984.     xchg  eax, ebx
  985.     jmp   @1
  986.  
  987. @0: inc   edx
  988. @1: mov   al, [ebx]
  989.     inc   ebx
  990.     cmp   al, [edx]
  991.     jne   @@Wrong
  992.     dec   ecx
  993.     jnz   @0
  994.  
  995.     mov   eax, 1
  996.     jmp   @@End
  997. @@Wrong:
  998.     mov   eax, 0
  999. @@End:
  1000.     pop   ebx
  1001. end;
  1002.  
  1003. function MaxI(A, B: Integer): Integer; assembler;
  1004. asm
  1005.   cmp  eax, edx
  1006.   jg   @@g
  1007.   xchg eax, edx
  1008. @@g:
  1009. end;
  1010.  
  1011.  
  1012. function MinI(A, B: Integer): Integer; assembler;
  1013. asm
  1014.   cmp  eax, edx
  1015.   jl   @@l
  1016.   xchg eax, edx
  1017. @@l:
  1018. end;
  1019.  
  1020.  
  1021. function MaxD(A, B: DWORD): DWORD; assembler;
  1022. asm
  1023.   cmp  eax, edx
  1024.   ja   @@a
  1025.   xchg eax, edx
  1026. @@a:
  1027. end;
  1028.  
  1029.  
  1030. function MinD(A, B: DWORD): DWORD; assembler;
  1031. asm
  1032.   cmp  eax, edx
  1033.   jb   @@b
  1034.   xchg eax, edx
  1035. @@b:
  1036. end;
  1037.  
  1038. procedure XChg(var Critical, Normal); assembler;
  1039. asm
  1040.   mov  ecx, [edx]
  1041.   xchg [eax], ecx
  1042.   mov  [edx], ecx
  1043. end;
  1044.  
  1045. function NulSearch; assembler;
  1046. asm;
  1047.   CLD
  1048.   PUSH    EDI
  1049.   MOV     EDI, Buffer
  1050.   XOR     AL,  AL
  1051.   MOV     ECX, -1
  1052.   REPNE   SCASB
  1053.   XCHG    EAX,ECX
  1054.   NOT     EAX
  1055.   DEC     EAX
  1056.   POP     EDI
  1057. end;
  1058.  
  1059. function Buf2Str(const Buffer): string;
  1060. var
  1061.   I: Integer;
  1062. begin
  1063.   I := NulSearch(Buffer);
  1064.   if I = 0 then Result := '' else
  1065.   begin
  1066.     SetLength(Result, I);
  1067.     Move(Buffer, Result[1], I);
  1068.   end;
  1069. end;
  1070.  
  1071. procedure LowerPrec(var A, B: Integer; Bits: Byte);
  1072. var
  1073.   C: ShortInt;
  1074. begin
  1075.   C := MaxI(NumBits(A), NumBits(B))-Bits;
  1076.   if C <= 0 then Exit;
  1077.   A := A shr C;
  1078.   B := B shr C;
  1079. end;
  1080.  
  1081.  
  1082.  
  1083. ////////////////////////////////////////////////////////////////////////
  1084. //                                                                    //
  1085. //                      Win32 Events Extentions                       //
  1086. //                                                                    //
  1087. ////////////////////////////////////////////////////////////////////////
  1088.  
  1089.  
  1090.  
  1091. function CreateEvtA;
  1092. begin
  1093.   Result := CreateEvent(nil, False, False, nil);
  1094. end;
  1095.  
  1096. function CreateEvt;
  1097. begin
  1098.   CreateEvt := CreateEvent(nil,      // address of security attributes
  1099.                            True,     // flag for manual-reset event
  1100.                            Initial,  // flag for initial state
  1101.                            nil);     // address of event-object name
  1102. end;
  1103.  
  1104. function  WaitEvtA(nCount: Integer; lpHandles: PWOHandleArray; Timeout: DWORD): DWORD;
  1105. begin
  1106.   if Timeout = High(Timeout) then Timeout := INFINITE;
  1107.   if nCount = 1 then Result := WaitForSingleObject(lpHandles^[0], Timeout) else
  1108.                      Result := WaitForMultipleObjects(nCount, lpHandles, False, Timeout);
  1109. end;
  1110.  
  1111. function WaitEvt;
  1112. begin
  1113.   Result := WaitEvtA(High(id)+1, @id, Timeout);
  1114. end;
  1115.  
  1116. function SignaledEvt(id: DWORD): Boolean;
  1117. begin
  1118.   SignaledEvt := WaitForSingleObject(id, 0) = id;
  1119. end;
  1120.  
  1121.  
  1122. ////////////////////////////////////////////////////////////////////////
  1123. //                                                                    //
  1124. //                      Win32 API Hooks                               //
  1125. //                                                                    //
  1126. ////////////////////////////////////////////////////////////////////////
  1127.  
  1128. procedure CloseHandles(const Handles: array of DWORD);
  1129. var
  1130.   i: Integer;
  1131. begin
  1132.   for i:=0 to High(Handles) do CloseHandle(Handles[i]);
  1133. end;
  1134.  
  1135. function FileExists(const FName: string): Boolean;
  1136. var
  1137.   Handle: DWORD;
  1138. begin
  1139.   Result := False;
  1140.   Handle := _CreateFile(FName, [cRead, cShareAllowWrite]);
  1141.   if Handle = INVALID_HANDLE_VALUE then Exit;
  1142.   Result := ZeroHandle(Handle);
  1143. end;
  1144.  
  1145. function GetFileNfo;
  1146. var
  1147.   Handle: DWORD;
  1148. begin
  1149.   Result := False;
  1150.   Handle := _CreateFile(FName, [cRead, cShareAllowWrite]);
  1151.   if Handle = INVALID_HANDLE_VALUE then Exit;
  1152.   Result := GetFileNfoByHandle(Handle, Info);
  1153.   CloseHandle(Handle);
  1154.   if NeedAttr and Result and (Info.Attr = INVALID_FILE_ATTRIBUTES) then Result := GetFileAttributes(PChar(FName)) <> INVALID_FILE_ATTRIBUTES;
  1155. end;
  1156.  
  1157. function GetFileNfoByHandle;
  1158. var
  1159.   i: TByHandleFileInformation;
  1160. begin
  1161.   Result := False;
  1162.   if Handle = INVALID_HANDLE_VALUE then Exit;
  1163.   i.dwFileAttributes := INVALID_FILE_ATTRIBUTES;
  1164.   i.nFileSizeLow := GetFileSize(Handle, nil);
  1165.   Result := (i.nFileSizeLow <> INVALID_FILE_SIZE) and GetFileTime(Handle, nil, nil, @i.ftLastWriteTime);
  1166.   if not Result then Exit;
  1167.   Info.Size := i.nFileSizeLow;
  1168.   Info.Attr := i.dwFileAttributes;
  1169.   Info.Time := uCvtGetFileTime(i.ftLastWriteTime.dwLowDateTime, i.ftLastWriteTime.dwHighDateTime);
  1170.   Result := True;
  1171. end;
  1172.  
  1173.  
  1174. function ClearHandle(var Handle: DWORD): Boolean;
  1175. begin
  1176.   if Handle = INVALID_HANDLE_VALUE then Result := False else
  1177.   begin
  1178.     Result := CloseHandle(Handle);
  1179.     Handle := INVALID_HANDLE_VALUE;
  1180.   end;
  1181. end;
  1182.  
  1183. function ZeroHandle(var Handle: DWORD): Boolean;
  1184. begin
  1185.   if (Handle = INVALID_HANDLE_VALUE) or
  1186.      (Handle = 0) then Result := False else
  1187.   begin
  1188.     Result := CloseHandle(Handle);
  1189.     Handle := 0;
  1190.   end;
  1191. end;
  1192.  
  1193. procedure _PostMessage(a, b, c, d: DWORD);
  1194. begin
  1195.   if not PostMessage(a, b, c, d) then
  1196.     GlobalFail;
  1197. end;
  1198.  
  1199. function _CreateFile;
  1200. begin
  1201.   Result := _CreateFileSecurity(FName, Mode, nil);
  1202. end;
  1203.  
  1204. function _CreateFileSecurity;
  1205. var
  1206.   Access,Share,Disp,Flags: DWORD;
  1207.  
  1208. const
  1209.   NumDispModes = 5;
  1210.   DispArr : array[1..NumDispModes] of
  1211.     record
  1212.       w: Boolean; {Write}
  1213.       n: Boolean; {EnsureNew}
  1214.       t: Boolean; {Truncate}
  1215.       d: DWORD; {Disp}
  1216.     end =
  1217.      ( (w:False; n:False; t:False; d:OPEN_EXISTING),
  1218.        (w:True;  n:False; t:False; d:OPEN_ALWAYS),
  1219.        (w:True;  n:True;  t:False; d:CREATE_NEW),
  1220.        (w:True;  n:False; t:True;  d:CREATE_ALWAYS),
  1221.        (w:True;  n:True;  t:True;  d:TRUNCATE_EXISTING) );
  1222. begin
  1223.  
  1224. // Prepare Disp & Flags
  1225.  
  1226.   Flags := FILE_ATTRIBUTE_NORMAL;
  1227.   Access := 0;
  1228.   Share := 0;
  1229.   Disp := 0;
  1230.  
  1231.   if cFlag in Mode then
  1232.   begin
  1233.     Disp := CREATE_NEW;
  1234.     Flags := Flags or FILE_FLAG_DELETE_ON_CLOSE
  1235.   end else
  1236.   begin
  1237.  
  1238.     if cTruncate in Mode then Mode := Mode + [cWrite];
  1239.  
  1240.     if cExisting in Mode then Disp := OPEN_EXISTING else
  1241.     begin
  1242.       if cWrite in Mode then Flags := FILE_ATTRIBUTE_ARCHIVE;
  1243.       repeat
  1244.         Inc(Disp); if Disp > NumDispModes then GlobalFail;
  1245.         with DispArr[Disp] do
  1246.         if (w = (cWrite in Mode)) and
  1247.            (n = (cEnsureNew in Mode)) and
  1248.            (t = (cTruncate in Mode)) then begin Disp := d; Break end;
  1249.       until False;
  1250.  
  1251.     end;
  1252.  
  1253.     if cOverlapped in Mode then Flags := Flags or FILE_FLAG_OVERLAPPED;
  1254.     if cRandomAccess in Mode then Flags := Flags or FILE_FLAG_RANDOM_ACCESS;
  1255.     if cSequentialScan in Mode then Flags := Flags or FILE_FLAG_SEQUENTIAL_SCAN;
  1256.     if cDeleteOnClose in Mode then Flags := Flags or FILE_FLAG_DELETE_ON_CLOSE;
  1257.  
  1258.  
  1259.   // Prepare 'Access' and 'Share'
  1260.  
  1261.     if cShareAllowWrite in Mode then Share := FILE_SHARE_WRITE;
  1262.     if cRead  in Mode then begin Access := Access or GENERIC_READ;  Share := Share or FILE_SHARE_READ end;
  1263.     if cWrite in Mode then begin Access := Access or GENERIC_WRITE; Share := Share or FILE_SHARE_READ end;
  1264.     if cShareDenyRead in Mode then Share := Share and not FILE_SHARE_READ;
  1265.   end;
  1266.  
  1267.   Result := CreateFile(PChar(FName), Access, Share, lpSecurityAttributes, Disp, Flags, 0);
  1268. end;
  1269.  
  1270.  
  1271. function _GetFileSize;
  1272. var
  1273.   H: DWORD;
  1274. begin
  1275.   Result := INVALID_FILE_SIZE;
  1276.   H := _CreateFile(FName, [cRead]);
  1277.   if H = INVALID_HANDLE_VALUE then Exit;
  1278.   Result := GetFileSize(H, nil);
  1279.   CloseHandle(H);
  1280. end;
  1281.  
  1282.  
  1283.  
  1284.  
  1285. function WindowsDirectory: string;
  1286. begin
  1287.   SetLength(Result, MAX_PATH);
  1288.   GetWindowsDirectory(PChar(Result), MAX_PATH);
  1289.   SetLength(Result, NulSearch(Result[1]));
  1290. end;
  1291.  
  1292.  
  1293.  
  1294. ////////////////////////////////////////////////////////////////////////
  1295. //                                                                    //
  1296. //                      Registry Routines                             //
  1297. //                                                                    //
  1298. ////////////////////////////////////////////////////////////////////////
  1299.  
  1300. function OpenRegKeyEx(const AName: string; AMode: DWORD): HKey;
  1301. begin
  1302.   if RegOpenKeyEx(
  1303.     HKEY_LOCAL_MACHINE,      // handle of an open key
  1304.     PChar(AName),           // subkey name
  1305.     0,                       // Reserved
  1306.     AMode,
  1307.     Result
  1308.   ) <> ERROR_SUCCESS then Result := INVALID_REGISTRY_KEY;
  1309. end;
  1310.  
  1311. function OpenRegKey(const AName: string): DWORD;
  1312. begin
  1313.   Result := OpenRegKeyEx(AName, KEY_QUERY_VALUE);
  1314. end;
  1315.  
  1316. function CreateRegKey(const AFName: string): HKey;
  1317. var
  1318.   Disp: DWORD;
  1319. begin
  1320.   if RegCreateKeyEx(
  1321.     HKEY_LOCAL_MACHINE,      // handle of an open key
  1322.     PChar(AFName),           // subkey name
  1323.     0,                       // reserved, must be zero
  1324.     nil,                     // address of class string
  1325.     REG_OPTION_NON_VOLATILE, // options flag
  1326.     KEY_WRITE,               // desired security access
  1327.     nil,                     // security attributes
  1328.     Result,                  // address of buffer for opened handle
  1329.     @Disp                    // address of disposition value buffer
  1330.   ) <> ERROR_SUCCESS then begin
  1331.     Result := INVALID_REGISTRY_KEY;
  1332.   end;
  1333.  
  1334. end;
  1335.  
  1336. function WriteRegString(Key: DWORD; const AStrName, AStr: string): Boolean;
  1337. begin
  1338.   Result := RegSetValueEx(Key, PChar(AStrName), 0, REG_SZ, PChar(AStr), Length(AStr)+1) = ERROR_SUCCESS;
  1339. end;
  1340.  
  1341.  
  1342. function ReadRegString(Key: DWORD; const AStrName: string): string;
  1343. var
  1344.   l, t,e: DWORD;
  1345.   z: ShortString;
  1346. begin
  1347.   z[0] := #250;
  1348.   l := 250;
  1349.   t := REG_SZ;
  1350.   e := RegQueryValueEx(
  1351.     Key,             // handle of key to query
  1352.     PChar(AStrName), // value to query
  1353.     nil,             // reserved
  1354.     @t,              // value type
  1355.     @z[1],           // data buffer
  1356.     @l               // buffer size
  1357.   );
  1358.   if e <> ERROR_SUCCESS then Result := '' else
  1359.   begin
  1360.     Result := Copy(z, 1, NulSearch(z[1]));
  1361.   end;
  1362. end;
  1363.  
  1364. function WriteRegInt(Key: DWORD; const AStrName: string; AValue: DWORD): Boolean;
  1365. begin
  1366.   Result := RegSetValueEx(Key, PChar(AStrName), 0, REG_DWORD, @AValue, SizeOf(AValue)) = ERROR_SUCCESS;
  1367. end;
  1368.  
  1369. function ReadRegInt(Key: DWORD; const AStrName: string): DWORD;
  1370. var
  1371.   t, e, s: DWORD;
  1372.   b: Integer;
  1373. begin
  1374.   t := REG_DWORD;;
  1375.   s := SizeOf(b);
  1376.   e := RegQueryValueEx(
  1377.     Key,             // handle of key to query
  1378.     PChar(AStrName), // value to query
  1379.     nil,             // reserved
  1380.     @t,              // value type
  1381.     @b,              // data buffer
  1382.     @s               // buffer size
  1383.   );
  1384.   if e <> ERROR_SUCCESS then Result := INVALID_REGISTRY_KEY else Result := b;
  1385. end;
  1386.  
  1387. function WriteRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  1388. begin
  1389.   Result := RegSetValueEx(Key, PChar(rvn), 0, REG_BINARY, Bin, Sz) = ERROR_SUCCESS;
  1390. end;
  1391.  
  1392. function ReadRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  1393. var
  1394.   t, e, s: DWORD;
  1395. begin
  1396.   t := REG_BINARY;;
  1397.   s := Sz;
  1398.   e := RegQueryValueEx(
  1399.     Key,             // handle of key to query
  1400.     PChar(rvn),      // value to query
  1401.     nil,             // reserved
  1402.     @t,              // value type
  1403.     Bin,             // data buffer
  1404.     @s               // buffer size
  1405.   );
  1406.   Result := e = ERROR_SUCCESS;
  1407. end;
  1408.  
  1409. ////////////////////////////////////////////////////////////////////////
  1410. //                                                                    //
  1411. //                             Objects                                //
  1412. //                                                                    //
  1413. ////////////////////////////////////////////////////////////////////////
  1414.  
  1415.  
  1416. function SysErrorMsg(ErrorCode: DWORD): string;
  1417. var
  1418.   Len: Integer;
  1419.   Buffer: array[0..255] of Char;
  1420. begin
  1421.   Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
  1422.     FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
  1423.     SizeOf(Buffer), nil);
  1424.   while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
  1425.   SetString(Result, Buffer, Len);
  1426. end;
  1427.  
  1428. procedure QuickSort(SortList: PItemList; L, R: Integer;
  1429.   SCompare: TListSortCompare);
  1430. var
  1431.   I, J: Integer;
  1432.   P, T: Pointer;
  1433. begin
  1434.   repeat
  1435.     I := L;
  1436.     J := R;
  1437.     P := SortList^[(L + R) shr 1];
  1438.     repeat
  1439.       while SCompare(SortList^[I], P) < 0 do Inc(I);
  1440.       while SCompare(SortList^[J], P) > 0 do Dec(J);
  1441.       if I <= J then
  1442.       begin
  1443.         T := SortList^[I];
  1444.         SortList^[I] := SortList^[J];
  1445.         SortList^[J] := T;
  1446.         Inc(I);
  1447.         Dec(J);
  1448.       end;
  1449.     until I > J;
  1450.     if L < J then QuickSort(SortList, L, J, SCompare);
  1451.     L := I;
  1452.   until I >= R;
  1453. end;
  1454.  
  1455.  
  1456. { ---- TColl ---- }
  1457.  
  1458. procedure TColl.Sort(Compare: TListSortCompare);
  1459. begin
  1460.   if (FList <> nil) and (Count > 0) then
  1461.     QuickSort(FList, 0, Count - 1, Compare);
  1462. end;
  1463.  
  1464.  
  1465. function TColl.Copy;
  1466. begin
  1467.   Result := TColl.Create;
  1468.   CopyItemsTo(TColl(Result));
  1469. end;
  1470.  
  1471. procedure TColl.CopyItemsTo;
  1472. var
  1473.   i: Integer;
  1474. begin
  1475.   Coll.FreeAll;
  1476.   for i := 0 to Count-1 do Coll.AtInsert(Coll.Count, CopyItem(At(i)));
  1477. end;
  1478.  
  1479. function TColl.CopyItem(AItem: Pointer): Pointer;
  1480. begin
  1481.   Result := TAdvCpObject(AItem).Copy;
  1482. end;
  1483.  
  1484. procedure TColl.Concat(AColl: TColl);
  1485. var
  1486.   i: Integer;
  1487. begin
  1488.   for i := 0 to AColl.Count-1 do Insert(AColl[i]);
  1489.   AColl.DeleteAll;
  1490. end;
  1491.  
  1492.  
  1493. procedure TColl.Enter;
  1494. var
  1495.   j: Integer;
  1496. begin
  1497.   j := 1; Xchg(Shared, j); if j = 0 then InitializeCriticalSection(CS);
  1498.   EnterCriticalSection(CS);
  1499. end;
  1500.  
  1501. procedure TColl.Leave;
  1502. begin
  1503.   LeaveCriticalSection(CS);
  1504. end;
  1505.  
  1506. procedure TColl.ForEach(Proc: TForEachProc);
  1507. var
  1508.   i: Integer;
  1509. begin
  1510.   for i := 0 to Count-1 do Proc(FList^[I]);
  1511. end;
  1512.  
  1513. constructor TColl.Create;
  1514. begin
  1515.   inherited Create;
  1516.   DoInit(32,64);
  1517. end;
  1518.  
  1519. procedure TColl.DoInit(ALimit, ADelta: Integer);
  1520. begin
  1521.   FList := nil;
  1522.   FCount := 0;
  1523.   FCapacity := 0;
  1524.   FDelta := ADelta;
  1525.   SetCapacity(ALimit);
  1526. end;
  1527.  
  1528.  
  1529. destructor TColl.Destroy;
  1530. begin
  1531.   if Shared = 1 then DeleteCriticalSection(CS);
  1532.   FreeAll;
  1533.   SetCapacity(0);
  1534.   inherited Destroy;
  1535. end;
  1536.  
  1537. function TColl.At(Index: Integer): Pointer;
  1538. begin
  1539.   if (Index < 0) or (Index >= FCount) then GlobalFail;
  1540.   Result := FList^[Index];
  1541. end;
  1542.  
  1543.  
  1544. procedure TColl.AtDelete(Index: Integer);
  1545. begin
  1546.   if (Index < 0) or (Index >= FCount) then GlobalFail;
  1547.   Dec(FCount);
  1548.   if Index < FCount then
  1549.     System.Move(FList^[Index + 1], FList^[Index],
  1550.       (FCount - Index) * SizeOf(Pointer));
  1551. end;
  1552.  
  1553. procedure TColl.AtFree(Index: Integer);
  1554. var
  1555.   Item: Pointer;
  1556. begin
  1557.   Item := At(Index);
  1558.   AtDelete(Index);
  1559.   FreeItem(Item);
  1560. end;
  1561.  
  1562. procedure TColl.AtInsert(Index: Integer; Item: Pointer);
  1563. begin
  1564.   if (Index < 0) or (Index > FCount) then GlobalFail;
  1565.   if FCount = FCapacity then SetCapacity(FCapacity + FDelta);
  1566.   if Index < FCount then
  1567.     System.Move(FList^[Index], FList^[Index + 1],
  1568.       (FCount - Index) * SizeOf(Pointer));
  1569.   FList^[Index] := Item;
  1570.   Inc(FCount);
  1571. end;
  1572.  
  1573. procedure TColl.AtPut(Index: Integer; Item: Pointer);
  1574. begin
  1575.   if (Index < 0) or (Index >= FCount) then GlobalFail;
  1576.   FList^[Index] := Item;
  1577. end;
  1578.  
  1579. procedure TColl.Delete(Item: Pointer);
  1580. begin
  1581.   AtDelete(IndexOf(Item));
  1582. end;
  1583.  
  1584. procedure TColl.DeleteAll;
  1585. begin
  1586.   FCount := 0;
  1587. end;
  1588.  
  1589. procedure TColl.FFree(Item: Pointer);
  1590. begin
  1591.   Delete(Item);
  1592.   FreeItem(Item);
  1593. end;
  1594.  
  1595. procedure TColl.FreeAll;
  1596. var
  1597.   I: Integer;
  1598. begin
  1599.   for I := 0 to FCount - 1 do FreeItem(At(I));
  1600.   FCount := 0;
  1601. end;
  1602.  
  1603. procedure TColl.FreeItem(Item: Pointer);
  1604. begin
  1605.   TObject(Item).Free;
  1606. end;
  1607.  
  1608. function TColl.IndexOf(Item: Pointer): Integer;
  1609. begin
  1610.   Result := 0;
  1611.   while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result);
  1612.   if Result = FCount then Result := -1;
  1613. end;
  1614.  
  1615. procedure TColl.Insert(Item: Pointer);
  1616. begin
  1617.   AtInsert(FCount, Item);
  1618. end;
  1619.  
  1620. procedure TColl.Add(Item: Pointer);
  1621. begin
  1622.   AtInsert(FCount, Item);
  1623. end;
  1624.  
  1625. procedure TColl.Pack;
  1626. var
  1627.   I: Integer;
  1628. begin
  1629.   for I := FCount - 1 downto 0 do if Items[I] = nil then AtDelete(I);
  1630. end;
  1631.  
  1632. procedure TColl.SetCapacity;
  1633. begin
  1634.   if (NewCapacity < FCount) or (NewCapacity > MaxCollSize) then GlobalFail;
  1635.   if NewCapacity <> FCapacity then
  1636.   begin
  1637.     ReallocMem(FList, NewCapacity * SizeOf(Pointer));
  1638.     FCapacity := NewCapacity;
  1639.   end;
  1640. end;
  1641.  
  1642. procedure TColl.MoveTo(CurIndex, NewIndex: Integer);
  1643. var
  1644.   Item: Pointer;
  1645. begin
  1646.   if CurIndex <> NewIndex then
  1647.   begin
  1648.     if (NewIndex < 0) or (NewIndex >= FCount) then GlobalFail;
  1649.     Item := FList^[CurIndex];
  1650.     AtDelete(CurIndex);
  1651.     AtInsert(NewIndex, Item);
  1652.   end;
  1653. end;
  1654.  
  1655. { TSortedColl }
  1656.  
  1657. function TSortedColl.KeyOf;
  1658. begin
  1659.   Result := Item;
  1660. end;
  1661.  
  1662. function TSortedColl.IndexOf(Item: Pointer): Integer;
  1663. var
  1664.   I: Integer;
  1665. begin
  1666.   IndexOf := -1;
  1667.   if Search(KeyOf(Item), I) then
  1668.   begin
  1669.     if Duplicates then
  1670.       while (I < Count) and (Item <> FList^[I]) do Inc(I);
  1671.     if I < Count then IndexOf := I;
  1672.   end;
  1673. end;
  1674.  
  1675. procedure TSortedColl.Insert(Item: Pointer);
  1676. var
  1677.   I: Integer;
  1678. begin
  1679.   if not Search(KeyOf(Item), I) or Duplicates then AtInsert(I, Item);
  1680. end;
  1681.  
  1682. function TSortedColl.Search(Key: Pointer; var Index: Integer): Boolean;
  1683. var
  1684.   L, H, I, C: Integer;
  1685. begin
  1686.   Search := False;
  1687.   L := 0;
  1688.   H := Count - 1;
  1689.   while L <= H do
  1690.   begin
  1691.     I := (L + H) shr 1;
  1692.     C := Compare(KeyOf(FList^[I]), Key);
  1693.     if C < 0 then L := I + 1 else
  1694.     begin
  1695.       H := I - 1;
  1696.       if C = 0 then
  1697.       begin
  1698.         Search := True;
  1699.         if not Duplicates then L := I;
  1700.       end;
  1701.     end;
  1702.   end;
  1703.   Index := L;
  1704. end;
  1705.  
  1706. { TStringColl }
  1707.  
  1708. function TStringColl.LongString: string;
  1709. var
  1710.   i: Integer;
  1711. begin
  1712.   Result := '';
  1713.   for i := 0 to Count-1 do Result := Result + Strings[i] + #13#10;
  1714. end;
  1715.  
  1716. function TStringColl.LongStringD(c: char): string;
  1717. var
  1718.   i: Integer;
  1719. begin
  1720.   Result := '';
  1721.   for i := 0 to Count-2 do Result := Result + Strings[i] + c;
  1722.   for i := MaxI(0, Count-1) to Count-1 do Result := Result + Strings[i];
  1723. end;
  1724.  
  1725. procedure TStringColl.SetTextStr(const Value: string);
  1726. var
  1727.   P, Start: PChar;
  1728.   S: string;
  1729. begin
  1730.   P := Pointer(Value);
  1731.   if P <> nil then
  1732.     while P^ <> #0 do
  1733.     begin
  1734.       Start := P;
  1735.       while not (P^ in [#0, #10, #13]) do Inc(P);
  1736.       System.SetString(S, Start, P - Start);
  1737.       Add(S);
  1738.       if P^ = #13 then Inc(P);
  1739.       if P^ = #10 then Inc(P);
  1740.     end;
  1741. end;
  1742.  
  1743.  
  1744. procedure TStringColl.FillEnum(Str: string; Delim: Char; Sorted: Boolean);
  1745. var
  1746.   Z: string;
  1747. begin
  1748.   while Str <> '' do
  1749.   begin
  1750.     GetWrd(Str, Z, Delim);
  1751.     if Sorted then Ins(Z) else Add(Z);
  1752.   end;
  1753. end;
  1754.  
  1755.  
  1756. function TStringColl.Found(const Str: string): Boolean;
  1757. var
  1758.   i: Integer;
  1759. begin
  1760.   Result := Search(@Str, I);
  1761. end;
  1762.  
  1763. function TStringColl.FoundU(const Str: string): Boolean;
  1764. var
  1765.   i: Integer;
  1766. begin
  1767.   Result := False;
  1768.   for i := 0 to Count-1 do if Str = Strings[i] then begin Result := True; Exit end;
  1769. end;
  1770.  
  1771. function TStringColl.FoundUC(const Str: string): Boolean;
  1772. var
  1773.   us: string;
  1774.   i: Integer;
  1775. begin
  1776.   us := UpperCase(Str);
  1777.   Result := False;
  1778.   for i := 0 to Count-1 do if us = UpperCase(Strings[i]) then begin Result := True; Exit end;
  1779. end;
  1780.  
  1781. function TStringColl.Copy;
  1782. begin
  1783.   Result := TStringColl.Create;
  1784.   CopyItemsTo(TColl(Result));
  1785. end;
  1786.  
  1787. function TStringColl.CopyItem(AItem: Pointer): Pointer;
  1788. begin
  1789.   Result := NewStr(PString(AItem)^);
  1790. end;
  1791.  
  1792.  
  1793. function TStringColl.KeyOf(Item: Pointer): Pointer;
  1794. begin
  1795.   KeyOf := Item;
  1796. end;
  1797.  
  1798. procedure TStringColl.Concat(AColl: TStringColl);
  1799. var
  1800.   i: Integer;
  1801. begin
  1802.   for i := 0 to AColl.Count - 1 do AtInsert(Count, AColl.At(I));
  1803.   AColl.DeleteAll;
  1804. end;
  1805.  
  1806. procedure TStringColl.AppendTo(AColl: TStringColl);
  1807. var
  1808.   i: Integer;
  1809. begin
  1810.   for i := 0 to Count - 1 do AColl.Add(Strings[i]);
  1811. end;
  1812.  
  1813. procedure TStringColl.Fill(const AStrs: array of string);
  1814. var
  1815.   i: Integer;
  1816. begin
  1817.   FreeAll;
  1818.   for i := Low(AStrs) to High(AStrs) do Add(AStrs[i]);
  1819. end;
  1820.  
  1821. procedure TStringColl.AddStrings(Strings: TStringColl; Sort: Boolean);
  1822. var
  1823.   i: Integer;
  1824. begin
  1825.   for i := 0 to Strings.Count-1 do
  1826.     if Sort then Ins(Strings[i]) else Add(Strings[i]);
  1827. end;
  1828.  
  1829. function TStringColl.IdxOf(Item: string): Integer;
  1830. begin
  1831.   Result := IndexOf(@Item);
  1832. end;
  1833.  
  1834. procedure TStringColl.SetString(Index: Integer; const Value: string);
  1835. begin
  1836.   FreeItem(At(Index));
  1837.   AtPut(Index, NewStr(Value));
  1838. end;
  1839.  
  1840. function TStringColl.GetString(Index: Integer): string;
  1841. begin
  1842.   Result := PString(At(Index))^;
  1843. end;
  1844.  
  1845. function TStringColl.Compare(Key1, Key2: Pointer): Integer;
  1846. begin
  1847.   Compare := CompareStr(PString(Key1)^, PString(Key2)^);
  1848. end;
  1849.  
  1850. procedure TStringColl.FreeItem(Item: Pointer);
  1851. begin
  1852.   DisposeStr(Item);
  1853. end;
  1854.  
  1855. procedure TStringColl.AtIns(Index: Integer; const Item: string);
  1856. begin
  1857.   AtInsert(Index, NewStr(Item));
  1858. end;
  1859.  
  1860. procedure TStringColl.Add(const S: string);
  1861. begin
  1862.   AtInsert(Count, NewStr(S));
  1863. end;
  1864.  
  1865. procedure TStringColl.Ins0(const S: string);
  1866. begin
  1867.   AtInsert(0, NewStr(S));
  1868. end;
  1869.  
  1870. procedure TStringColl.Ins(const S: string);
  1871. begin
  1872.   Insert(NewStr(S));
  1873. end;
  1874.  
  1875. procedure FreeObject(var O);
  1876. var
  1877.   OO: TObject absolute O;
  1878.   OP: Pointer absolute O;
  1879. begin
  1880.   if OP <> nil then begin OO.Free; OP := nil end;
  1881. end;
  1882.  
  1883. function DeleteEmptyDirInheritance(S: string; const StopOn: string): Integer;
  1884. begin
  1885.   Result := 0;
  1886.   while (S <> StopOn) and RemoveDirectory(PChar(S)) do
  1887.   begin
  1888.     Inc(Result);
  1889.     S := ExtractFileDir(S);
  1890.   end;
  1891. end;
  1892.  
  1893. const
  1894.   CMonths = 'JanFebMarAprMayJunJulAugSepOctNovDec';
  1895.   Months: string[Length(CMonths)] = CMonths;
  1896.  
  1897. function MonthE(m: Integer): string;
  1898. begin
  1899.   Result := Copy(Months, 1+(m-1)*3, 3);
  1900. end;
  1901.  
  1902.  
  1903. procedure GlobalFail;
  1904. begin
  1905. //  WriteLn('Global Failure!!!');
  1906.   Halt;
  1907. end;
  1908.  
  1909.  
  1910.  
  1911. function CreateTCollEL: TColl;
  1912. begin
  1913.   Result := TColl.Create;
  1914.   TColl(Result).Enter;
  1915.   TColl(Result).Leave;
  1916. end;
  1917.  
  1918. procedure XorStr(P: PByteArray; Len: Integer; const S: string);
  1919. var
  1920.   sl, i: Integer;
  1921. begin
  1922.   sl := Length(s); if sl = 0 then Exit;
  1923.   for i := 0 to Len-1 do
  1924.   begin
  1925.     P^[i] := P^[i] xor Byte(S[(i mod sl)+1]);
  1926.   end;
  1927. end;
  1928.  
  1929. function GetEnvVariable(const Name: string): string;
  1930. const
  1931.   BufSize = 128;
  1932. var
  1933.   Buf: array[0..BufSize] of Char;
  1934.   I: DWORD;
  1935. begin
  1936.   I := GetEnvironmentVariable(PChar(Name), Buf, BufSize);
  1937.   case I of
  1938.     1..BufSize:
  1939.       begin
  1940.         SetLength(Result, I);
  1941.         Move(Buf, Result[1], I);
  1942.       end;
  1943.     BufSize+1..MaxInt:
  1944.       begin
  1945.         SetLength(Result, I+1);
  1946.         GetEnvironmentVariable(PChar(Name), @Result[1], I);
  1947.         SetLength(Result, I);
  1948.       end;
  1949.     else
  1950.       begin
  1951.         Result := '';
  1952.       end;
  1953.    end;
  1954. end;
  1955.  
  1956. function LoadRS(Ident: Integer): string;
  1957. const
  1958.    strbufsize = $10000;
  1959. var
  1960.    strbuf: array[0..StrBufSize] of Char;
  1961. begin
  1962.   SetString(Result, PChar(@strbuf), LoadString(hInstance, Ident, @strbuf, strbufsize));
  1963. end;
  1964.  
  1965. function StrBegins(const s1,s2:string):Boolean;
  1966. begin
  1967.   Result := Copy(s1, 1, Length(s2)) = s2;
  1968. end;
  1969.  
  1970. function DivideDash(const S: string): string;
  1971. begin
  1972.   Result := S;
  1973.   Insert('-', Result, (Length(S) div 2)+1);
  1974. end;
  1975.  
  1976. procedure MoveColl(Src, Dst: TColl; Idx: Integer);
  1977. begin
  1978.   if Idx = -1 then Exit;
  1979.   Dst.Insert(Src[Idx]);
  1980.   Src.AtDelete(Idx);
  1981. end;
  1982.  
  1983.  
  1984. function TempFileName(const APath, APfx: string): string;
  1985. var
  1986.   s: string;
  1987. begin
  1988.   SetLength(s, 1000);
  1989.   GetTempFileName(PChar(APath), PChar(APfx), 0, @s[1]);
  1990.   Result := Copy(s, 1, NulSearch(s[1]));
  1991. end;
  1992.  
  1993. function CreateTempFile(const APath, APfx: string; var FName: string): DWORD;
  1994. begin
  1995.   FName := TempFileName(APath, APfx);
  1996.   Result := _CreateFile(FName, [cWrite, cExisting]);
  1997. end;
  1998.  
  1999. { TThread }
  2000.  
  2001. function ThreadProc(Thread: TThread): DWORD;
  2002. var
  2003.   FreeThread: Boolean;
  2004. begin
  2005.   Thread.Execute;
  2006.   FreeThread := Thread.FFreeOnTerminate;
  2007.   Result := Thread.FReturnValue;
  2008.   Thread.FFinished := True;
  2009.   if FreeThread then Thread.Free;
  2010.   EndThread(Result);
  2011. end;
  2012.  
  2013. constructor TThread.Create(CreateSuspended: Boolean);
  2014. var
  2015.   Flags: DWORD;
  2016. begin
  2017.   inherited Create;
  2018.   FSuspended := CreateSuspended;
  2019.   Flags := 0;
  2020.   if CreateSuspended then Flags := CREATE_SUSPENDED;
  2021.   FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), Flags, FThreadID);
  2022. end;
  2023.  
  2024. destructor TThread.Destroy;
  2025. begin
  2026.   if FHandle <> 0 then CloseHandle(FHandle);
  2027.   inherited Destroy;
  2028. end;
  2029.  
  2030. const
  2031.   Priorities: array [TThreadPriority] of Integer =
  2032.    (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
  2033.     THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
  2034.     THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
  2035.  
  2036. function TThread.GetPriority: TThreadPriority;
  2037. var
  2038.   P: Integer;
  2039.   I: TThreadPriority;
  2040. begin
  2041.   P := GetThreadPriority(FHandle);
  2042.   Result := tpNormal;
  2043.   for I := Low(TThreadPriority) to High(TThreadPriority) do
  2044.     if Priorities[I] = P then Result := I;
  2045. end;
  2046.  
  2047. procedure TThread.SetPriority(Value: TThreadPriority);
  2048. begin
  2049.   SetThreadPriority(FHandle, Priorities[Value]);
  2050. end;
  2051.  
  2052. procedure TThread.SetSuspended(Value: Boolean);
  2053. begin
  2054.   if Value <> FSuspended then
  2055.     if Value then
  2056.       Suspend else
  2057.       Resume;
  2058. end;
  2059.  
  2060. procedure TThread.Suspend;
  2061. begin
  2062.   FSuspended := True;
  2063.   SuspendThread(FHandle);
  2064. end;
  2065.  
  2066. procedure TThread.Resume;
  2067. begin
  2068.   if ResumeThread(FHandle) = 1 then FSuspended := False;
  2069. end;
  2070.  
  2071. procedure TThread.Terminate;
  2072. begin
  2073.   FTerminated := True;
  2074. end;
  2075.  
  2076. function NumBits(I: Integer): Integer; assembler;
  2077. asm
  2078.   bsr eax, eax
  2079.   jz @z
  2080.   inc eax
  2081. @z:
  2082. end;
  2083.  
  2084.  
  2085.  
  2086. function ExtractFilePath(const FileName: string): string;
  2087. var
  2088.   I: Integer;
  2089. begin
  2090.   I := LastDelimiter('\:', FileName);
  2091.   Result := Copy(FileName, 1, I);
  2092. end;
  2093.  
  2094. function ExtractFileDir(const FileName: string): string;
  2095. var
  2096.   I: Integer;
  2097. begin
  2098.   I := LastDelimiter('\:',Filename);
  2099.   if (I > 1) and (FileName[I] = '\') and
  2100.     (not (FileName[I - 1] in ['\', ':'])) then Dec(I);
  2101.   Result := Copy(FileName, 1, I);
  2102. end;
  2103.  
  2104. function ExtractFileDrive(const FileName: string): string;
  2105. var
  2106.   I, J: Integer;
  2107. begin
  2108.   if (Length(FileName) >= 2) and (FileName[2] = ':') then
  2109.     Result := Copy(FileName, 1, 2)
  2110.   else if (Length(FileName) >= 2) and (FileName[1] = '\') and
  2111.     (FileName[2] = '\') then
  2112.   begin
  2113.     J := 0;
  2114.     I := 3;
  2115.     While (I < Length(FileName)) and (J < 2) do
  2116.     begin
  2117.       if FileName[I] = '\' then Inc(J);
  2118.       if J < 2 then Inc(I);
  2119.     end;
  2120.     if FileName[I] = '\' then Dec(I);
  2121.     Result := Copy(FileName, 1, I);
  2122.   end else Result := '';
  2123. end;
  2124.  
  2125. function LastDelimiter(const Delimiters, S: string): Integer;
  2126. begin
  2127.   Result := Length(S);
  2128.   while Result > 0 do
  2129.   begin
  2130.     if (S[Result] <> #0) and (Pos(S[Result], Delimiters) = 0) then Dec(Result) else Break;
  2131.   end;
  2132. end;
  2133.  
  2134. function ExtractFileName(const FileName: string): string;
  2135. var
  2136.   I: Integer;
  2137. begin
  2138.   I := LastDelimiter('\:', FileName);
  2139.   Result := Copy(FileName, I + 1, MaxInt);
  2140. end;
  2141.  
  2142. function ExtractFileExt(const FileName: string): string;
  2143. var
  2144.   I: Integer;
  2145. begin
  2146.   I := LastDelimiter('.\:', FileName);
  2147.   if (I > 0) and (FileName[I] = '.') then
  2148.     Result := Copy(FileName, I, MaxInt) else
  2149.     Result := '';
  2150. end;
  2151.  
  2152. function ExpandFileName(const FileName: string): string;
  2153. var
  2154.   FName: PChar;
  2155.   Buffer: array[0..MAX_PATH - 1] of Char;
  2156. begin
  2157.   SetString(Result, Buffer, GetFullPathName(PChar(FileName), SizeOf(Buffer),
  2158.     Buffer, FName));
  2159. end;
  2160.  
  2161.  
  2162. function UpperCase(const S: string): string;
  2163. var
  2164.   Ch: Char;
  2165.   L: Integer;
  2166.   Source, Dest: PChar;
  2167. begin
  2168.   L := Length(S);
  2169.   SetLength(Result, L);
  2170.   Source := Pointer(S);
  2171.   Dest := Pointer(Result);
  2172.   while L <> 0 do
  2173.   begin
  2174.     Ch := Source^;
  2175.     if (Ch >= 'a') and (Ch <= 'z') then Dec(Ch, 32);
  2176.     Dest^ := Ch;
  2177.     Inc(Source);
  2178.     Inc(Dest);
  2179.     Dec(L);
  2180.   end;
  2181. end;
  2182.  
  2183. function LowerCase(const S: string): string;
  2184. var
  2185.   Ch: Char;
  2186.   L: Integer;
  2187.   Source, Dest: PChar;
  2188. begin
  2189.   L := Length(S);
  2190.   SetLength(Result, L);
  2191.   Source := Pointer(S);
  2192.   Dest := Pointer(Result);
  2193.   while L <> 0 do
  2194.   begin
  2195.     Ch := Source^;
  2196.     if (Ch >= 'A') and (Ch <= 'Z') then Inc(Ch, 32);
  2197.     Dest^ := Ch;
  2198.     Inc(Source);
  2199.     Inc(Dest);
  2200.     Dec(L);
  2201.   end;
  2202. end;
  2203.  
  2204. const
  2205.   EmptyStr: string = '';
  2206.   NullStr: PString = @EmptyStr;
  2207.  
  2208. function NewStr(const S: string): PString;
  2209. begin
  2210.   if S = '' then Result := NullStr else
  2211.   begin
  2212.     New(Result);
  2213.     Result^ := S;
  2214.   end;
  2215. end;
  2216.  
  2217. procedure DisposeStr(P: PString);
  2218. begin
  2219.   if (P <> nil) and (P^ <> '') then Dispose(P);
  2220. end;
  2221.  
  2222. function CompareStr(const S1, S2: string): Integer; assembler;
  2223. asm
  2224.         PUSH    ESI
  2225.         PUSH    EDI
  2226.         MOV     ESI,EAX
  2227.         MOV     EDI,EDX
  2228.         OR      EAX,EAX
  2229.         JE      @@1
  2230.         MOV     EAX,[EAX-4]
  2231. @@1:    OR      EDX,EDX
  2232.         JE      @@2
  2233.         MOV     EDX,[EDX-4]
  2234. @@2:    MOV     ECX,EAX
  2235.         CMP     ECX,EDX
  2236.         JBE     @@3
  2237.         MOV     ECX,EDX
  2238. @@3:    CMP     ECX,ECX
  2239.         REPE    CMPSB
  2240.         JE      @@4
  2241.         MOVZX   EAX,BYTE PTR [ESI-1]
  2242.         MOVZX   EDX,BYTE PTR [EDI-1]
  2243. @@4:    SUB     EAX,EDX
  2244.         POP     EDI
  2245.         POP     ESI
  2246. end;
  2247.  
  2248. function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
  2249. asm
  2250.         PUSH    ESI
  2251.         PUSH    EDI
  2252.         MOV     ESI,P1
  2253.         MOV     EDI,P2
  2254.         MOV     EDX,ECX
  2255.         XOR     EAX,EAX
  2256.         AND     EDX,3
  2257.         SHR     ECX,1
  2258.         SHR     ECX,1
  2259.         REPE    CMPSD
  2260.         JNE     @@2
  2261.         MOV     ECX,EDX
  2262.         REPE    CMPSB
  2263.         JNE     @@2
  2264. @@1:    INC     EAX
  2265. @@2:    POP     EDI
  2266.         POP     ESI
  2267. end;
  2268.  
  2269.  
  2270. procedure TSocket.RegisterSelf;
  2271. begin
  2272.   SocketsColl.Enter;
  2273.   SocketsColl.Insert(Self);
  2274.   Registered := True;
  2275.   SocketsColl.Leave;
  2276. end;
  2277.  
  2278. procedure TSocket.DeregisterSelf;
  2279. begin
  2280.   SocketsColl.Enter;
  2281.   if Registered then SocketsColl.Delete(Self);
  2282.   Registered := False;
  2283.   SocketsColl.Leave;
  2284. end;
  2285.  
  2286.  
  2287. function TSocket.Startup: Boolean;
  2288. begin
  2289.   Result := True;
  2290. end;
  2291.  
  2292. function TSocket.Handshake: Boolean;
  2293. begin
  2294.   Result := True;
  2295. end;
  2296.  
  2297.  
  2298. destructor TSocket.Destroy;
  2299. begin
  2300.   DeregisterSelf;
  2301.   CloseSocket(Handle);
  2302.   SocketsColl.Enter;
  2303.   Dec(SocksCount);
  2304.   if SocksCount = 0 then ResetterThread.TimeToSleep := INFINITE;
  2305.   SocketsColl.Leave;
  2306.   inherited Destroy;
  2307. end;
  2308.  
  2309. function TSocket.Read(var B; Size: DWORD): DWORD;
  2310. begin
  2311.   Result := _Read(B, Size);
  2312.   Dead := 0;
  2313. end;
  2314.  
  2315. function TSocket.Write(const B; Size: DWORD): DWORD;
  2316. const
  2317.   cWrite = $4000;
  2318. var
  2319.   p: PByteArray;
  2320.   Written, Left, i, WriteNow: DWORD;
  2321. begin
  2322.   p := @B;
  2323.   i := 0;
  2324.   Left := Size;
  2325.   while Left > 0 do
  2326.   begin
  2327.     WriteNow := MinD(Left, cWrite);
  2328.     Written := _Write(p^[i], WriteNow);
  2329.     Dead := 0;
  2330.     Inc(i, Written);
  2331.     Dec(Left, Written);
  2332.     if Written <> WriteNow then Break;
  2333.   end;
  2334.   Result := i;
  2335. end;
  2336.  
  2337.  
  2338.  
  2339. function TSocket.WriteStr(const s: string): DWORD;
  2340. var
  2341.   slen: Integer;
  2342. begin
  2343.   slen := Length(s);
  2344.   if slen > 0 then Result := Write(s[1], slen) else Result := 0;
  2345. end;
  2346.  
  2347. function TSocket._Write(const B; Size: DWORD): DWORD;
  2348. var
  2349.   I: Integer;
  2350. begin
  2351.   I := send(Handle, (@B)^, Size, 0);
  2352.   if (I = SOCKET_ERROR) or (I < 0) then begin Status := WSAGetLastError; Result := 0 end else Result := I;
  2353. end;
  2354.  
  2355. function TSocket._Read(var B; Size: DWORD): DWORD;
  2356. var
  2357.   i: Integer;
  2358. begin
  2359.   i := recv(Handle, B, Size, 0);
  2360.   if (i = SOCKET_ERROR) or (I < 0) then begin Status := WSAGetLastError; Result := 0 end else Result := i;
  2361. end;
  2362.  
  2363. function Inet2addr(const s: string): DWORD;
  2364. begin
  2365.   Result := inet_addr(PChar(s));
  2366. end;
  2367.  
  2368. function __pchar(c: char): Boolean;
  2369. begin
  2370.   case c of
  2371.     ':', '@', '&', '=', '+': Result := True
  2372.     else Result := __uchar(c)
  2373.   end;
  2374. end;
  2375.  
  2376. function __uchar(c: char): Boolean;
  2377. begin
  2378.   Result := __alpha(c) or __digit(c) or __safe(c) or __extra(c) or __national(c)
  2379. end;
  2380.  
  2381. function __national(c: char): Boolean;
  2382. begin
  2383.   case c of
  2384.     '0'..'9', 'A'..'Z', 'a'..'z': Result := False;
  2385.     else Result := not (__reserved(c) or __extra(c) or __safe(c) or __unsafe(c));
  2386.   end;
  2387. end;
  2388.  
  2389. function __reserved(c: char): Boolean;
  2390. begin
  2391.   case c of
  2392.     ';', '/', '?', ':', '@', '&', '=', '+' : Result := True
  2393.     else Result := False;
  2394.   end;
  2395. end;
  2396.  
  2397. function __extra(c: char): Boolean;
  2398. begin
  2399.   case c of
  2400.     '!', '*', '''' ,'(', ')', ',' : Result := True
  2401.     else Result := False;
  2402.   end;
  2403. end;
  2404.  
  2405. function __safe(c: char): Boolean;
  2406. begin
  2407.   case c of
  2408.     '$', '-', '_', '.' : Result := True
  2409.     else Result := False;
  2410.   end;
  2411. end;
  2412.  
  2413. function __unsafe(c: char): Boolean;
  2414. begin
  2415.   case c of
  2416.       '"', '#', '%', '<', '>': Result := True;
  2417.     else Result := __ctl(c);
  2418.   end;
  2419. end;
  2420.  
  2421. function __alpha(c: char): Boolean;
  2422. begin
  2423.   case c of
  2424.     'A'..'Z', 'a'..'z': Result := True
  2425.     else Result := False;
  2426.   end;
  2427. end;
  2428.  
  2429. function __digit(c: char): Boolean;
  2430. begin
  2431.   case c of
  2432.     '0'..'9': Result := True
  2433.     else Result := False;
  2434.   end;
  2435. end;
  2436.  
  2437. function __ctl(c: char): Boolean;
  2438. begin
  2439.   case c of
  2440.     #0..#31, #127 : Result := True
  2441.     else Result := False;
  2442.   end;
  2443. end;
  2444.  
  2445.  
  2446. function UnpackXchars(var s: string; p: Boolean): Boolean;
  2447. var
  2448.   r: string;
  2449.   c: char;
  2450.   i, h, l, sl: Integer;
  2451.  
  2452. begin
  2453.   Result := False;
  2454.   sl := Length(s);
  2455.   i := 0;
  2456.   while i < sl do
  2457.   begin
  2458.     Inc(i);
  2459.     c := s[i];
  2460.     if c = '%' then
  2461.     begin
  2462.       if i > sl-2 then Exit;
  2463.       l := Pos(UpCase(s[i+2]), rrHiHexChar)-1;
  2464.       h := Pos(UpCase(s[i+1]), rrHiHexChar)-1;
  2465.       if (h = -1) or (l = -1) then Exit;
  2466.       r := r + Chr(h shl 4 or l);
  2467.       Inc(i, 2);
  2468.       Continue;
  2469.     end;
  2470.     if p then
  2471.     begin
  2472.       if not __pchar(c) and (c <> '/') then Exit;
  2473.     end else
  2474.     begin
  2475.       if not __uchar(c) then Exit
  2476.     end;
  2477.     r := r + c;
  2478.   end;
  2479.   s := r;
  2480.   Result := True;
  2481. end;
  2482.  
  2483. function UnpackUchars(var s: string): Boolean;
  2484. begin
  2485.   Result := UnpackXchars(s, False);
  2486. end;
  2487.  
  2488.  
  2489. function UnpackPchars(var s: string): Boolean;
  2490. begin
  2491.   Result := UnpackXchars(s, True);
  2492. end;
  2493.  
  2494. function ProcessQuotes(var s: string): Boolean;
  2495. var
  2496.   r: string;
  2497.   i: Integer;
  2498.   KVC: Boolean;
  2499.   c: Char;
  2500. begin
  2501.   Result := False;
  2502.   KVC := False;
  2503.   for i := 1 to Length(s) do
  2504.   begin
  2505.     c := s[i];
  2506.     case c of
  2507.       #0..#9, #11..#12, #14..#31 : Exit;
  2508.       '"' : begin KVC := not KVC; Continue end;
  2509.     end;
  2510.     if KVC then r := r + '%' + Hex2(Byte(c)) else r := r + c;
  2511.   end;
  2512.   Result := not KVC;
  2513.   if Result then s := r;
  2514. end;
  2515.  
  2516. function _Val(const S: string; var V: Integer): Boolean;
  2517. var
  2518.   I, R: Integer;
  2519.   C: Char;
  2520. begin
  2521.   Result := False;
  2522.   if S = '' then Exit;
  2523.   R := 0;
  2524.   for I := 1 to Length(S) do
  2525.   begin
  2526.     C := S[I];
  2527.     if not __digit(C) then Exit;
  2528.     R := (R * 10) + Ord(C) - Ord('0');
  2529.   end;
  2530.   Result := True;
  2531.   V := R;
  2532. end;
  2533.  
  2534.  
  2535. function StoI(const S: string): Integer;
  2536. begin
  2537.   if not _Val(S, Result) then Result := 0;
  2538. end;
  2539.  
  2540. function _LogOK(const Name: string; var Handle: DWORD): Boolean;
  2541. begin
  2542.   if Handle = 0 then
  2543.   begin
  2544.     Handle := _CreateFile(Name, [cWrite]);
  2545.     if Handle <> INVALID_HANDLE_VALUE then if SetFilePointer(Handle, 0, nil, FILE_END) = INVALID_FILE_SIZE then ClearHandle(Handle);
  2546.   end;
  2547.   Result := Handle <> INVALID_HANDLE_VALUE;
  2548. end;
  2549.  
  2550. function InetAddr(const s: string): DWORD;
  2551. begin
  2552.   Result := inet_addr(PChar(s))
  2553. end;
  2554.  
  2555. function AddrInet(i: DWORD): string;
  2556. var
  2557.   r: record a, b, c, d: Byte end absolute i;
  2558. begin
  2559.   Result := ItoS(r.a)+'.'+ItoS(r.b)+'.'+ItoS(r.c)+'.'+ItoS(r.d);
  2560. end;
  2561.  
  2562.  
  2563. const
  2564.     shell32 = 'shell32.dll';
  2565.  
  2566.  
  2567. function FindExecutable; external shell32 name 'FindExecutableA';
  2568.  
  2569.  
  2570. procedure XAdd(var Critical, Normal); assembler;
  2571. asm
  2572.   mov  ecx, [edx]
  2573.   xadd [eax], ecx  // !!! i486+
  2574.   mov  [edx], ecx
  2575. end;
  2576.  
  2577. procedure GetBias;
  2578. var
  2579.   T, L: TFileTime;
  2580.   a, b, c: DWORD;
  2581. begin
  2582.   GetSystemTimeAsFileTime(T);
  2583.   FileTimeToLocalFileTime(T, L);
  2584.   a := uCvtGetFileTime(T.dwLowDateTime, T.dwHighDateTime);
  2585.   b := uCvtGetFileTime(L.dwLowDateTime, L.dwHighDateTime);
  2586.   if a > b then
  2587.   begin
  2588.     c := a - b;
  2589.     TimeZoneBias := c;
  2590.   end else
  2591.   begin
  2592.     c := b - a;
  2593.     TimeZoneBias := c;
  2594.     TimeZoneBias := - TimeZoneBias;
  2595.   end;
  2596. end;
  2597.  
  2598. type
  2599.   THostCache = class
  2600.     Addr: DWORD;
  2601.     Name: string;
  2602.   end;
  2603.  
  2604.   THostCacheColl = class(TSortedColl)
  2605.     function Compare(Key1, Key2: Pointer): Integer; override;
  2606.     function KeyOf(Item: Pointer): Pointer; override;
  2607.   end;
  2608.  
  2609. var
  2610.   HostCache: THostCacheColl;
  2611.  
  2612. function THostCacheColl.Compare(Key1, Key2: Pointer): Integer;
  2613. begin
  2614.   Result := Integer(Key1) - Integer(Key2);
  2615. end;
  2616.  
  2617. function THostCacheColl.KeyOf(Item: Pointer): Pointer;
  2618. begin
  2619.   Result := Pointer(THostCache(Item).Addr);
  2620. end;
  2621.  
  2622.  
  2623. function GetHostNameByAddr(Addr: DWORD): string;
  2624. var
  2625.   p: PHostEnt;
  2626.   i: Integer;
  2627.   f: Boolean;
  2628.   c: THostCache;
  2629.   ok: Boolean;
  2630.   he: PHostEnt;
  2631.   HostName: string;
  2632. begin
  2633.   HostCache.Enter;
  2634.   f := HostCache.Search(Pointer(Addr), i);
  2635.   if f then Result := StrAsg(THostCache(HostCache[i]).Name);
  2636.   HostCache.Leave;
  2637.   if f then Exit;
  2638.   p := gethostbyaddr(@addr, 4, PF_INET);
  2639.   ok := False;
  2640.   if p <> nil then
  2641.   begin // host name got - now get address of this name
  2642.     HostName := p^.h_name;
  2643.     he := gethostbyname(PChar(HostName));
  2644.     if (he <> nil) and (he^.h_addr_list <> nil) then
  2645.     begin // address got - now compare it with the real one
  2646.       ok := PDwordArray(he^.h_addr_list^)^[0] = Addr;
  2647.     end;
  2648.   end;
  2649.   if ok then Result := HostName else Result := AddrInet(Addr);
  2650.   HostCache.Enter;
  2651.   f := HostCache.Search(Pointer(Addr), i);
  2652.   if not f then
  2653.   begin
  2654.     c := THostCache.Create;
  2655.     c.Addr := Addr;
  2656.     c.Name := StrAsg(Result);
  2657.     HostCache.AtInsert(i, c);
  2658.   end;
  2659.   HostCache.Leave;
  2660. end;
  2661.  
  2662. function Vl(const s: string): DWORD;
  2663. var
  2664.   a, i, l: Integer;
  2665.   c: Char;
  2666. begin
  2667.   Result := INVALID_VALUE;
  2668.   l := Length(s);
  2669.   if L > 9 then Exit;
  2670.   a := 0;
  2671.   for i := 1 to l do
  2672.   begin
  2673.     C := s[i];
  2674.     if (C < '0') or (C > '9') then Exit;
  2675.     a := a * 10 + Ord(C) - Ord('0');
  2676.   end;
  2677.   Result := a;
  2678. end;
  2679.  
  2680.  
  2681. procedure xBaseInit;
  2682. begin
  2683.   GetBias;
  2684.   HostCache := THostCacheColl.Create;
  2685.   HostCache.Enter;
  2686.   HostCache.Leave;
  2687. end;
  2688.  
  2689. procedure xBaseDone;
  2690. begin
  2691.   FreeObject(HostCache);
  2692. end;
  2693.  
  2694. constructor TResetterThread.Create;
  2695. begin
  2696.   inherited Create(False);
  2697.   oSleep := CreateEvent(nil, False, False, nil);
  2698.   TimeToSleep := INFINITE;
  2699. end;
  2700.  
  2701. destructor TResetterThread.Destroy;
  2702. begin
  2703.   CloseHandle(oSleep);
  2704.   inherited Destroy;
  2705. end;
  2706.  
  2707.  
  2708. procedure TResetterThread.Execute;
  2709. const
  2710.   KillQuants = 5; // Quants to shut down socket for inactivity
  2711. var
  2712.   i: Integer;
  2713.   s: TSocket;
  2714. begin
  2715.   repeat
  2716.     WaitForSingleObject(oSleep, TimeToSleep);
  2717.     if Terminated then Break;
  2718.     SocketsColl.Enter;
  2719.     for i := 0 to SocketsColl.Count - 1 do
  2720.     begin
  2721.       s := SocketsColl[i];
  2722.       if s.Dead < 0 then Continue; // Already shut down
  2723.       Inc(s.Dead);
  2724.       if s.Dead <= KillQuants then Continue; // This one shows activity - let him live
  2725.       s.Dead := -1; // Mark
  2726.        // disable both sends and receives
  2727.       shutdown(s.Handle, 2);
  2728.     end;
  2729.     SocketsColl.Leave;
  2730.   until Terminated;
  2731. end;
  2732.  
  2733.  
  2734. function CompareMask(const n, m: string; SupportPercent: Boolean): Boolean;
  2735. var
  2736.   i: Integer;
  2737. begin
  2738.   Result := False;
  2739.   for i := 1 to Length(m) do
  2740.   begin
  2741.     if (m[i] = '?') then Continue;
  2742.     if (i > Length(n)) or (n[i] <> m[i]) then
  2743.     begin
  2744.       if SupportPercent and (m[i] = '%') and (n[i] in ['0'..'9']) then else Exit;
  2745.     end;
  2746.   end;
  2747.   Result := True;
  2748. end;
  2749.  
  2750. function PosMask(const m, s: string; SupportPercent: Boolean): Integer;
  2751. var
  2752.   i: Integer;
  2753. begin
  2754.   Result := 0;
  2755.   for i := 1 to Length(s)-Length(m)+1 do
  2756.   begin
  2757.     if CompareMask(Copy(s, i, Length(m)), m, SupportPercent) then
  2758.     begin
  2759.       Result := i;
  2760.       Exit;
  2761.     end;
  2762.   end;
  2763. end;
  2764.  
  2765. function MatchMask(const AName, AMask: string): Boolean;
  2766. begin
  2767.   Result := _MatchMask(AName, AMask, False);
  2768. end;
  2769.  
  2770. function _MatchMaskBody(AName, AMask: string; SupportPercent: Boolean): Boolean;
  2771. var
  2772.   i, j: Integer;
  2773.   Scan: Boolean;
  2774. begin
  2775.   Result := False;
  2776.   Scan := False;
  2777.   while True do
  2778.   begin
  2779.     i := Pos('*', AMask);
  2780.     if i = 0 then
  2781.     begin
  2782.       if AMask = '' then begin Result := True; Exit end;
  2783.       j := PosMask(AMask, AName, SupportPercent); if j=0 then Exit;
  2784.       if (j+Length(AMask)) <= Length(AName) then Exit;
  2785.       Result := True;
  2786.       Exit;
  2787.     end else
  2788.     begin
  2789.       if i > 1 then
  2790.       begin
  2791.         if Scan then j := PosMask(Copy(AMask, 1, i-1), AName, SupportPercent) else if CompareMask(AName, Copy(AMask, 1, i-1), SupportPercent) then j := i-1 else j := 0;
  2792.         if j = 0 then Exit else Delete(AName, 1, j);
  2793.       end;
  2794.       Delete(AMask, 1, i);
  2795.     end;
  2796.     Scan := True;
  2797.   end;
  2798. end;
  2799.  
  2800. function _MatchMask(const AName: string; AMask: string; SupportPercent: Boolean): Boolean;
  2801. begin
  2802.   Replace('?*', '*', AMask);
  2803.   Replace('*?', '*', AMask);
  2804.   Replace('**', '*', AMask);
  2805.   Result := _MatchMaskBody(UpperCase(AName), UpperCase(AMask), SupportPercent);
  2806. end;
  2807.  
  2808. function FromHex(C1, C2: Char): Char;
  2809.   var I1, I2: Byte;
  2810. begin
  2811.   case C1 of
  2812.     '0'..'9': I1 := Byte(C1)-48;
  2813.     'A'..'F': I1 := Byte(C1)-55;
  2814.     'a'..'f': I1 := Byte(C1)-87;
  2815.       else I1 := 0;
  2816.   end;
  2817.   case C2 of
  2818.     '0'..'9': I2 := Byte(C2)-48;
  2819.     'A'..'F': I2 := Byte(C2)-55;
  2820.     'a'..'f': I2 := Byte(C2)-87;
  2821.       else I2 := 0;
  2822.   end;
  2823.   Result := Char(I1 shl 4 + I2);
  2824. end;
  2825.  
  2826. constructor TMimeCoder.Create;
  2827. begin
  2828.   case AType of
  2829.     bsBase64: begin
  2830.                 Table:='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  2831.                 MaxChars := 57;
  2832.                 Pad := '=';
  2833.               end;
  2834.     bsUUE: begin
  2835.              Table := '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';
  2836.              Pad := '`';
  2837.              MaxChars := 45;
  2838.            end;
  2839.     bsXXE: begin
  2840.              Table := '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  2841.              Pad := '+';
  2842.              MaxChars := 45;
  2843.            end;
  2844.   end;
  2845.   InitTable;
  2846. end;
  2847.  
  2848. procedure TMimeCoder.InitTable;
  2849.   var I: Integer;
  2850. begin
  2851.   FillChar(XChars, SizeOf(XChars), 65);
  2852.   for I := 1 to Length(Table) do XChars[Table[I]] := I-1;
  2853.   XChars[Pad] := 0;
  2854.   if Pad = '`' then XChars[' '] := 0;
  2855. end;
  2856.  
  2857. function TMimeCoder.EncodeStr;
  2858. begin
  2859.   if S = '' then Result := ''
  2860.     else Result := Encode(S[1], Length(S));
  2861. end;
  2862.  
  2863. function IsUUEStr(const S: String): Boolean;
  2864.   var I: Integer;
  2865. begin
  2866.   Result := False;
  2867.   for I := 1 to Length(S) do
  2868.     if (S[I] < '!') or (S[I] > '`') then Exit;
  2869.   Result := True;
  2870. end;
  2871.  
  2872. function TMimeCoder.Encode;
  2873. var
  2874.   B: Array[0..MMaxChars] of Byte;
  2875.   I,K,L: Word;
  2876.   S: Str255;
  2877. begin
  2878.   FillChar(B, SizeOf(B), 0);
  2879.   Move(Buf, B, N);
  2880.   L := N;
  2881.   if L mod 3 <> 0 then Inc(L, 3);
  2882.   S[0] := Char((L div 3) * 4);
  2883.   FillChar(S[1], Length(S), Pad);
  2884.   I := 0; K := 1;
  2885.   while I < N do
  2886.     begin
  2887.       S[K]   := Table[1+(B[I] shr 2)];
  2888.       S[K+1] := Table[1+(((B[I] and $03) shl 4) or (B[I+1] shr 4))];
  2889.       if I+1 >= N then Break;
  2890.       S[K+2] := Table[1+(((B[I+1] and $0F) shl 2) or (B[I+2] shr 6))];
  2891.       if I+2 >= N then Break;
  2892.       S[K+3] := Table[1+(B[I+2] and $3F)];
  2893.       Inc(I, 3); Inc(K, 4);
  2894.     end;
  2895.   Result := S;
  2896. end;
  2897.  
  2898. function TMimeCoder.EncodeBuf(const Buf; N: byte; var OutBuf) : Integer;
  2899. var
  2900.   B: Array[0..MMaxChars] of Byte;
  2901.   I,K,L: Word;
  2902.   p: PCharArray;
  2903. begin
  2904.   p := @OutBuf;
  2905.   FillChar(B, SizeOf(B), 0);
  2906.   Move(Buf, B, N);
  2907.   L := N;
  2908.   if L mod 3 <> 0 then Inc(L, 3);
  2909.   Result := (L div 3) * 4;
  2910.   FillChar(p^, Result, Pad);
  2911.   I := 0; K := 0;
  2912.   while I < N do
  2913.     begin
  2914.       p^[K]   := Table[1+(B[I] shr 2)];
  2915.       p^[K+1] := Table[1+(((B[I] and $03) shl 4) or (B[I+1] shr 4))];
  2916.       if I+1 >= N then Break;
  2917.       p^[K+2] := Table[1+(((B[I+1] and $0F) shl 2) or (B[I+2] shr 6))];
  2918.       if I+2 >= N then Break;
  2919.       p^[K+3] := Table[1+(B[I+2] and $3F)];
  2920.       Inc(I, 3); Inc(K, 4);
  2921.     end;
  2922. end;
  2923.  
  2924.  
  2925.  
  2926.  
  2927. function TMimeCoder.Decode;
  2928.   var B: array [0..MMaxChars] of Byte absolute Buf;
  2929.       A: array [0..MMaxChars] of Byte;
  2930.       I,J,K, Pdd: Integer;
  2931. begin
  2932.   if S = '' then begin Result := 0; Exit end;
  2933.   Result := -1;
  2934.   FillChar(A, SizeOf(A), 0);
  2935.   for I := 0 to Length(S)-1 do
  2936.     begin
  2937.       A[I] := XChars[S[I+1]];
  2938.       if A[I] > 64 then Exit;
  2939.     end;
  2940.   J := Length(S);
  2941.   Pdd := 3;
  2942.   if (Pad = '=') then
  2943.     while S[J] = Pad do begin Dec(Pdd); Dec(J) end;
  2944.   Pdd := Pdd mod 3;
  2945.   Result := (J div 4) * 3 + Pdd;
  2946.   I := 0; K := 0;
  2947.   while I < J do
  2948.     begin
  2949.       B[K] := ((A[I] shl 2) or (A[I+1] shr 4)) and $FF;
  2950.       B[K+1] := ((A[I+1] shl 4) or (A[I+2] shr 2)) and $FF;
  2951.       B[K+2] := ((A[I+2] shl 6) or (A[I+3])) and $FF;
  2952.       Inc(I, 4); Inc(K, 3);
  2953.     end;
  2954. end;
  2955.  
  2956. function TMimeCoder.DecodeBuf(const SrcBuf; SrcLen: Integer; var Buf): Integer;
  2957. var
  2958.   B: array [0..MMaxChars] of Byte absolute Buf;
  2959.   A: array [0..MMaxChars] of Byte;
  2960.   I,J,K, Pdd: Integer;
  2961.   p: PByteArray;
  2962. begin
  2963.   p := @SrcBuf;
  2964.   if SrcLen = 0 then begin Result := 0; Exit end;
  2965.   Result := -1;
  2966.   FillChar(A, SizeOf(A), 0);
  2967.   for I := 0 to SrcLen-1 do
  2968.     begin
  2969.       A[I] := XChars[Char(P^[I])];
  2970.       if A[I] > 64 then Exit;
  2971.     end;
  2972.   J := SrcLen;
  2973.   Pdd := 3;
  2974.   if (Pad = '=') then
  2975.     while (J>0) and (Char(p^[J-1]) = Pad) do begin Dec(Pdd); Dec(J) end;
  2976.   Pdd := Pdd mod 3;
  2977.   Result := (J div 4) * 3 + Pdd;
  2978.   I := 0; K := 0;
  2979.   while I < J do
  2980.     begin
  2981.       B[K] := ((A[I] shl 2) or (A[I+1] shr 4)) and $FF;
  2982.       B[K+1] := ((A[I+1] shl 4) or (A[I+2] shr 2)) and $FF;
  2983.       B[K+2] := ((A[I+2] shl 6) or (A[I+3])) and $FF;
  2984.       Inc(I, 4); Inc(K, 3);
  2985.     end;
  2986. end;
  2987.  
  2988. function StrAsg(const Src: string): string;
  2989. begin
  2990.   if Src = '' then Result := '' else
  2991.   begin
  2992.     SetLength(Result, Length(Src));
  2993.     Move(Src[1], Result[1], Length(Src));
  2994.   end;
  2995. end;
  2996.  
  2997.  
  2998. end.
  2999.  
  3000.  
  3001.